Commit 43033a50 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Remove Global again

parent 588a7b49
{
"name": "base",
"version": "2.0.0",
"version": "3.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Base libraries for Curry systems",
"description": "This package contains the base libraries which are directly distributed with specific versions of the Curry systems PAKCS and KiCS2.",
......
------------------------------------------------------------------------------
--- Library for handling global entities.
--- A global entity has a name declared in the program.
--- Its value can be accessed and modified by IO actions.
--- Furthermore, global entities can be declared as persistent so that
--- their values are stored across different program executions.
---
--- Currently, it is still experimental so that its interface might
--- be slightly changed in the future.
---
--- A global entity `g` with an initial value `v`
--- of type `t` must be declared by:
---
--- g :: Global t
--- g = global v spec
---
--- Here, the type `t` must not contain type variables and
--- `spec` specifies the storage mechanism for the
--- global entity (see type `GlobalSpec`).
---
---
--- @author Michael Hanus
--- @version February 2017
--- @category general
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Global( Global, GlobalSpec(..), global
, readGlobal, safeReadGlobal, writeGlobal)
where
----------------------------------------------------------------------
--- The abstract type of a global entity.
#ifdef __PAKCS__
data Global a = GlobalDef a GlobalSpec
#else
external data Global _
#endif
--- `global` is only used for the declaration of a global value
--- and should not be used elsewhere. In the future, it might become a keyword.
global :: a -> GlobalSpec -> Global a
#ifdef __PAKCS__
global v s = GlobalDef v s
#else
global external
#endif
--- The storage mechanism for the global entity.
--- @cons Temporary - the global value exists only during a single execution
--- of a program
--- @cons Persistent f - the global value is stored persisently in file f
--- (which is created and initialized if it does not exists)
data GlobalSpec = Temporary | Persistent String
--- Reads the current value of a global.
readGlobal :: Global a -> IO a
readGlobal g = prim_readGlobal $# g
prim_readGlobal :: Global a -> IO a
prim_readGlobal external
--- Safely reads the current value of a global.
--- If `readGlobal` fails (e.g., due to a corrupted persistent storage),
--- the global is re-initialized with the default value given as
--- the second argument.
safeReadGlobal :: Global a -> a -> IO a
safeReadGlobal g dflt =
catch (readGlobal g) (\_ -> writeGlobal g dflt >> return dflt)
--- Updates the value of a global.
--- The value is evaluated to a ground constructor term before it is updated.
writeGlobal :: Global a -> a -> IO ()
writeGlobal g v = (prim_writeGlobal $# g) $## v
prim_writeGlobal :: Global a -> a -> IO ()
prim_writeGlobal external
------------------------------------------------------------------------
import CurryException
import Control.Exception as C
import Data.IORef
import System.IO
import System.Directory (doesFileExist)
import System.IO.Unsafe
import System.Process (system)
-- Implementation of Globals in Curry. We use Haskell's IORefs for temporary
-- globals where Curry values are stored in the IORefs
data C_Global a
= Choice_C_Global Cover ID (C_Global a) (C_Global a)
| Choices_C_Global Cover ID ([C_Global a])
| Fail_C_Global Cover FailInfo
| Guard_C_Global Cover Constraints (C_Global a)
| C_Global_Temp (IORef a) -- a temporary global
| C_Global_Pers String -- a persistent global with a given (file) name
instance Show (C_Global a) where
show = error "ERROR: no show for Global"
instance Read (C_Global a) where
readsPrec = error "ERROR: no read for Global"
instance NonDet (C_Global a) where
choiceCons = Choice_C_Global
choicesCons = Choices_C_Global
failCons = Fail_C_Global
guardCons = Guard_C_Global
try (Choice_C_Global cd i x y) = tryChoice cd i x y
try (Choices_C_Global cd i xs) = tryChoices cd i xs
try (Fail_C_Global cd info) = Fail cd info
try (Guard_C_Global cd c e) = Guard cd c e
try x = Val x
match choiceF _ _ _ _ _ (Choice_C_Global cd i x y) = choiceF cd i x y
match _ narrF _ _ _ _ (Choices_C_Global cd i@(NarrowedID _ _) xs)
= narrF cd i xs
match _ _ freeF _ _ _ (Choices_C_Global cd i@(FreeID _ _) xs)
= freeF cd i xs
match _ _ _ failF _ _ (Fail_C_Global cd info) = failF cd info
match _ _ _ _ guardF _ (Guard_C_Global cd c e) = guardF cd c e
match _ _ _ _ _ valF x = valF x
instance Generable (C_Global a) where
generate _ _ = error "ERROR: no generator for Global"
instance NormalForm (C_Global a) where
($!!) cont g@(C_Global_Temp _) cd cs = cont g cd cs
($!!) cont g@(C_Global_Pers _) cd cs = cont g cd cs
($!!) cont (Choice_C_Global d i g1 g2) cd cs = nfChoice cont d i g1 g2 cd cs
($!!) cont (Choices_C_Global d i gs) cd cs = nfChoices cont d i gs cd cs
($!!) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $!! g) cd
$! (addCs c cs))
($!!) _ (Fail_C_Global d info) _ _ = failCons d info
($##) cont g@(C_Global_Temp _) cd cs = cont g cd cs
($##) cont g@(C_Global_Pers _) cd cs = cont g cd cs
($##) cont (Choice_C_Global d i g1 g2) cd cs = gnfChoice cont d i g1 g2 cd cs
($##) cont (Choices_C_Global d i gs) cd cs = gnfChoices cont d i gs cd cs
($##) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $## g) cd
$! (addCs c cs))
($##) _ (Fail_C_Global cd info) _ _ = failCons cd info
searchNF _ cont g@(C_Global_Temp _) = cont g
searchNF _ cont g@(C_Global_Pers _) = cont g
instance Unifiable (C_Global a) where
(=.=) (C_Global_Temp ref1) (C_Global_Temp ref2) _ _
| ref1 == ref2 = C_True
(=.=) (C_Global_Pers f1) (C_Global_Pers f2) _ _
| f1 == f2 = C_True
(=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo
(=.<=) = (=.=)
bind cd i (Choice_C_Global d j l r)
= [(ConstraintChoice d j (bind cd i l) (bind cd i r))]
bind cd i (Choices_C_Global d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs
bind cd i (Choices_C_Global d j@(NarrowedID _ _) xs)
= [(ConstraintChoices d j (map (bind cd i) xs))]
bind _ _ (Fail_C_Global _ info) = [Unsolvable info]
bind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ (bind cd i e)
lazyBind cd i (Choice_C_Global d j l r)
= [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))]
lazyBind cd i (Choices_C_Global d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs
lazyBind cd i (Choices_C_Global d j@(NarrowedID _ _) xs)
= [(ConstraintChoices d j (map (lazyBind cd i) xs))]
lazyBind _ _ (Fail_C_Global cd info) = [Unsolvable info]
lazyBind cd i (Guard_C_Global _ cs e)
= (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))]
instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_Global a)
external_d_C_global :: Curry_Prelude.Curry a => a -> C_GlobalSpec -> Cover -> ConstStore
-> C_Global a
external_d_C_global val C_Temporary _ _ = ref `seq` (C_Global_Temp ref)
where ref = unsafePerformIO (newIORef val)
external_d_C_global val (C_Persistent cname) _ _ =
let name = fromCurry cname :: String
in unsafePerformIO (initGlobalFile name >> return (C_Global_Pers name))
where initGlobalFile name = do
ex <- doesFileExist name
if ex then return ()
else writeFile name (show val++"\n")
external_d_C_prim_readGlobal :: Curry_Prelude.Curry a => C_Global a -> Cover -> ConstStore
-> Curry_Prelude.C_IO a
external_d_C_prim_readGlobal (C_Global_Temp ref) _ _ = fromIO (readIORef ref)
external_d_C_prim_readGlobal (C_Global_Pers name) _ _ = fromIO $
exclusiveOnFile name $ do
s <- catch (do h <- openFile name ReadMode
eof <- hIsEOF h
s <- if eof then return "" else hGetLine h
hClose h
return s)
(\e -> throw (IOException (show (e :: C.IOException))))
case reads s of
[(val,"")] -> return val
_ -> throw (IOException $ "Persistent file `" ++ name ++
"' contains malformed contents")
external_d_C_prim_writeGlobal :: Curry_Prelude.Curry a => C_Global a -> a
-> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_writeGlobal (C_Global_Temp ref) val _ _ =
toCurry (writeIORef ref val)
external_d_C_prim_writeGlobal (C_Global_Pers name) val _ _ =
toCurry (exclusiveOnFile name $ writeFile name (show val ++ "\n"))
--- Forces the exclusive execution of an action via a lock file.
exclusiveOnFile :: String -> IO a -> IO a
exclusiveOnFile file action = do
exlock <- doesFileExist lockfile
if exlock
then hPutStrLn stderr
(">>> Waiting for removing lock file `" ++ lockfile ++ "'...")
else return ()
system ("lockfile-create --lock-name "++lockfile)
C.catch (do actionResult <- action
deleteLockFile
return actionResult )
(\e -> deleteLockFile >> C.throw (e :: CurryException))
where
lockfile = file ++ ".LOCK"
deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_readGlobal" arity="1">
<library>prim_global</library>
<entry>prim_readGlobal</entry>
</primitive>
<primitive name="prim_writeGlobal" arity="2">
<library>prim_global</library>
<entry>prim_writeGlobal</entry>
</primitive>
</primitives>
......@@ -7,12 +7,10 @@
------------------------------------------------------------------------------
module System.Environment
( getArgs, getEnv, getEnvironment, setEnv, unsetEnv, getProgName
( getArgs, getEnv, setEnv, unsetEnv, getProgName
, getHostname, isPosix, isWindows
) where
import Global
--- Returns the list of the program's command line arguments.
--- The program name is not included.
......@@ -23,19 +21,13 @@ getArgs external
--- The empty string is returned for undefined environment variables.
getEnv :: String -> IO String
getEnv evar = do
envs <- getEnvironment
maybe (prim_getEnviron $## evar) return (lookup evar envs)
getEnv evar = prim_getEnviron $## evar
prim_getEnviron :: String -> IO String
prim_getEnviron external
getEnvironment :: IO [(String, String)]
getEnvironment = readGlobal environ
--- internal state of environment variables set via setEnviron
environ :: Global [(String,String)]
environ = global [] Temporary
getEnvironment external
--- Set an environment variable to a value.
--- The new value will be passed to subsequent shell commands
......@@ -44,17 +36,19 @@ environ = global [] Temporary
--- of the process that started the program execution).
setEnv :: String -> String -> IO ()
setEnv evar val = do
envs <- getEnvironment
writeGlobal environ ((evar,val) : filter ((/=evar) . fst) envs)
setEnv evar val = (prim_setEnviron $## evar) $## val
prim_setEnviron :: String -> String -> IO ()
prim_setEnviron external
--- Removes an environment variable that has been set by
--- <code>setEnv</code>.
unsetEnv :: String -> IO ()
unsetEnv evar = do
envs <- getEnvironment
writeGlobal environ (filter ((/=evar) . fst) envs)
unsetEnv evar = prim_unsetEnviron $ evar
prim_unsetEnviron :: String -> IO ()
prim_unsetEnviron external
--- Returns the hostname of the machine running this process.
......
{-# LANGUAGE CPP #-}
import Control.Exception as C (IOException, handle)
import Network.BSD (getHostName)
import System.Environment (getArgs, getEnv, getProgName)
import Control.Exception as C (IOException, handle)
import Network.BSD (getHostName)
#if __GLASGOW_HASKELL__ < 840
import System.Environment (getArgs, getEnv, setEnv, unsetEnv, getProgName)
#else
import System.Environment (getArgs, getProgName)
import System.Environment.Blank (setEnv, getEnvDefault, unsetEnv)
#endif
external_d_C_getArgs :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List Curry_Prelude.C_String)
external_d_C_getArgs _ _ = toCurry getArgs
#if __GLASGOW_HASKELL__ < 840
external_d_C_prim_getEnviron :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_prim_getEnviron str _ _ =
......@@ -13,6 +19,35 @@ external_d_C_prim_getEnviron str _ _ =
where
handleIOException :: IOException -> IO String
handleIOException _ = return ""
#elif
external_d_C_prim_getEnviron :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_prim_getEnviron str _ _ =
toCurry (\v -> getEnvDefault v "") str
#endif
external_d_C_prim_getEnvironment :: Cover -> ConstStore ->
-> Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_Prelude.C_String))
external_d_C_prim_getEnvironment _ _ = toCurry getEnvironment
#if __GLASGOW_HASKELL__ < 840
external_d_C_prim_setEnviron :: Curry_Prelude.C_String -> Curry_Prelude.C_String
-> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_prim_setEnviron str val _ _ =
toCurry setEnv str val
#elif
external_d_C_prim_setEnviron :: Curry_Prelude.C_String -> Curry_Prelude.C_String
-> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_prim_setEnviron str val _ _ =
toCurry (\s v -> setEnv s v True) str val
#endif
external_d_C_prim_unsetEnviron :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_prim_getEnviron str _ _ =
toCurry unsetEnv str
external_d_C_getHostname :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_getHostname _ _ = toCurry getHostName
......
......@@ -9,6 +9,18 @@
<library>prim_system</library>
<entry>prim_getEnviron</entry>
</primitive>
<primitive name="getEnvironment" arity="0">
<library>prim_system</library>
<entry>prim_getEnviron</entry>
</primitive>
<primitive name="prim_setEnviron" arity="2">
<library>prim_system</library>
<entry>prim_setEnviron</entry>
</primitive>
<primitive name="prim_unsetEnviron" arity="1">
<library>prim_system</library>
<entry>prim_unsetEnviron</entry>
</primitive>
<primitive name="getHostname" arity="0">
<library>prim_system</library>
<entry>prim_getHostname</entry>
......
Markdown is supported
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