Commit e7436048 authored by Bernd Brassel's avatar Bernd Brassel
Browse files

all standard libraries collected

parent c092c880
......@@ -13,7 +13,7 @@ Description: This package builds the Curry to Haskell compiler "kics".
Note, that you need a functional curry module
"Prelude.curry" to get started.
The standard version of that file is contained
in the package KiCS-libraries.
in the package KiCS-standard-libraries.
Stability: experimental
Executable kics
......
......@@ -117,7 +117,7 @@ data ConsUse = DataDef | InstanceDef | FunctionDef deriving (Eq,Show)
libpath :: Options -> [String]
libpath opts@Opts{userlibpath=up,{-kicspath=kp,-}filename=fn}
= --(case takeDirectory fn of "" -> id; dir -> ((dir++[pathSeparator]):))
up ++ [unpath ["src","lib",""]]
up -- ++ [unpath ["Curry","Module",""]]
cmdLibpath :: Options -> String
......@@ -366,18 +366,16 @@ getModTime fn = safeIO (do
ex<-doesModuleExist fn
if ex then getModuleModTime fn else return (TOD 0 0))
safeReadFlat opts s = do
safeIO $ print s
safeIO $ print $ libpath opts
fs <- safeIO (findFileInPath s (libpath opts))
safeIO $ print 12
fn <- warning s (cmdLibpath opts) fs
mprog <- safeIO $ readFlat fn
maybe (fail $ "file not found: "++fn) return mprog
warning fn path [] = fail ("module "++fn++" not found in path "++path)
warning fn path [] = fail ("file "++fn++" not found in path "++path)
warning _ _ (f:fs) = do
mapM_ (safeIO . putStrLn)
(map (\f' -> "further file found (but ignored) "++f'
......
......@@ -52,7 +52,11 @@ showProg = showProgOpt defaultPrintOptions
showProgOpt :: PrintOptions -> Prog -> String
showProgOpt opts p@(Prog m imports exports typedecls insdecls funcdecls opdecls)
= "{-# OPTIONS -cpp #-}\n\n"
++ "{-# LANGUAGE RankNTypes, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}\n\n"
++ "{-# LANGUAGE RankNTypes,\
\ ScopedTypeVariables,\
\ MultiParamTypeClasses,\
\ FlexibleInstances,\
\ TypeSynonymInstances #-}\n\n"
++ "module "++m++showExports opts m exports ++" where\n\n"
++ showImports imports
++ "\n\n-- begin included\n\n"
......
--- This program includes a list of all system libraries
module All_Libraries (
--general libraries
--module AllSolutions,
--module Assertion,
module Char,
--module CLPFD,
--module CLPR,
--module CLPB,
module Combinatorial,
module CSV,
--module DaVinci,
module Directory,
module Distribution,
module FileGoodies,
module Float,
module GUI,
module Integer,
module IO,
module IOExts,
--module KeyDB,
module List,
module Maybe,
module NamedObjectServer,
module Parser,
--module Ports,
module Profile,
module PropertyFile,
module ReadNumeric,
--module ReadAnswer,
module ReadShowTerm,
module Socket,
module System,
module Time,
--module Tk,
module Traversal,
module Unsafe,
-- Data structures and algorithms
module Array,
module Dequeue,
module FiniteMap,
module GraphInductive,
--module IArray,
module Random,
-- module RandomExternal,
module RedBlackTree,
module SetRBT,
module Sort,
module TableRBT,
-- Libraries for web applications
module CategorizedHtmlList,
module CgiServer,
module HTML,
module HtmlParser,
module URL,
module WUI,
module XML,
--module XmlConv,
-- Libraries for persistent data
module Dynamic,
module JDBC,
module SQL,
module DBSpec,
-- Libraries for meta-programming
module AbstractCurry,
module AbstractCurryPrinter,
module CurryStringClassifier,
module FlatCurry,
module FlatCurryGoodies,
module FlatCurryRead,
module FlatCurryShow,
module FlatCurryTools,
module FlatCurryXML,
module FlexRigid,
module CurrySyntax,
--module Generic,
module Meta,
module PrettyFlat,
--internal libraries
module Interactive,
test) where
--import AllSolutions
--import Assertion
import Char
--import CLPFD
--import CLPR (minimumFor)
--import CLPB
import Combinatorial
import CSV
--import DaVinci
import Distribution hiding (FrontendParams)
import Directory
import FileGoodies
import Float
import GUI
import Integer
import IO
import IOExts
--import KeyDB
import List(find)
import Maybe
import NamedObjectServer
import Parser((>>>))
--import Ports
import Profile
import PropertyFile
--import ReadAnswer
import ReadNumeric
import ReadShowTerm
import Socket
import System
import Time
--import Tk(tkChooseColor)
import Traversal
import Unsafe(trace)
-- Data structures and algorithms
import Array hiding ((!))
import Dequeue
import FiniteMap
import GraphInductive(Graph)
--import IArray ((!))
import Random
-- import RandomExternal
import RedBlackTree(RedBlackTree)
import SetRBT(SetRBT)
import Sort
import TableRBT(TableRBT)
--Libraries for web applications:
import CategorizedHtmlList
import CgiServer
import HTML
import HtmlParser
import URL
import WUI
import XML
--import XmlConv
-- Libraries for persistent data
import Dynamic (Dynamic)
import JDBC hiding (update)
import SQL
import DBSpec
-- from directory meta:
import AbstractCurry (CurryProg)
import AbstractCurryPrinter
import CurryStringClassifier (Token)
import FlatCurry
import FlatCurryGoodies (updFunc)
import FlatCurryRead
import FlatCurryShow hiding (showCurryId)
import FlatCurryTools(showCurryId)
import FlatCurryXML
import FlexRigid
--import Generic
import Meta hiding (isFree)
import PrettyFlat (Precs)
import CurrySyntax (Module)
import Interactive
test = putStrLn "okay"
[ForFunction "prim_Float_plus",ForFunction "prim_Float_minus",ForFunction "prim_Float_times",ForFunction "prim_Float_divide",ForFunction "prim_Float_lt",ForFunction "prim_Float_gt",ForFunction "prim_Float_leq",ForFunction "prim_Float_geq",ForFunction "prim_i2f",ForFunction "prim_truncate",ForFunction "prim_round",ForFunction "prim_sqrt",ForFunction "prim_log",ForFunction "prim_exp",ForFunction "prim_sin",ForFunction "prim_cos",ForFunction "prim_tan"]
\ No newline at end of file
[ForFunction "prim_Float_plus"
,ForFunction "prim_Float_minus"
,ForFunction "prim_Float_times"
,ForFunction "prim_Float_divide"
,ForFunction "prim_Float_lt"
,ForFunction "prim_Float_gt"
,ForFunction "prim_Float_leq"
,ForFunction "prim_Float_geq"
,ForFunction "prim_i2f"
,ForFunction "prim_truncate"
,ForFunction "prim_round"
,ForFunction "prim_sqrt"
,ForFunction "prim_log"
,ForFunction "prim_exp"
,ForFunction "prim_sin"
,ForFunction "prim_cos"
,ForFunction "prim_tan"
]
instance Fractional C_Float where
fromRational x = PrimValue (fromRational x)
recip (PrimValue x) = PrimValue (recip x)
instance Floating C_Float where
pi = PrimValue pi
exp (PrimValue x) = PrimValue (exp x)
log (PrimValue x) = PrimValue (log x)
sin (PrimValue x) = PrimValue (sin x)
cos (PrimValue x) = PrimValue (cos x)
sinh (PrimValue x) = PrimValue (sinh x)
cosh (PrimValue x) = PrimValue (cosh x)
asin (PrimValue x) = PrimValue (asin x)
acos (PrimValue x) = PrimValue (acos x)
atan (PrimValue x) = PrimValue (atan x)
asinh (PrimValue x) = PrimValue (asinh x)
acosh (PrimValue x) = PrimValue (acosh x)
atanh (PrimValue x) = PrimValue (atanh x)
instance RealFrac C_Float where
properFraction (PrimValue x) = case properFraction x of (b,a) -> (b,PrimValue a)
prim_Float_plus :: C_Float -> C_Float -> Result C_Float
prim_Float_plus x y _ = x+y
prim_Float_minus :: C_Float -> C_Float -> Result C_Float
prim_Float_minus x y _ = x-y
prim_Float_times :: C_Float -> C_Float -> Result C_Float
prim_Float_times x y _ = x*y
prim_Float_divide :: C_Float -> C_Float -> Result C_Float
prim_Float_divide x y _ = x/y
prim_Float_lt :: C_Float -> C_Float -> Result C_Bool
prim_Float_lt x y _ = toCurry (x<y)
prim_Float_gt :: C_Float -> C_Float -> Result C_Bool
prim_Float_gt x y _ = toCurry (x>y)
prim_Float_leq :: C_Float -> C_Float -> Result C_Bool
prim_Float_leq x y _ = toCurry (x<=y)
prim_Float_geq :: C_Float -> C_Float -> Result C_Bool
prim_Float_geq x y _ = toCurry (x>=y)
prim_i2f :: C_Int -> Result C_Float
prim_i2f x _ = fromInteger (fromCurry x)
prim_truncate :: C_Float -> Result C_Int
prim_truncate x _ = toCurry (truncate x :: Integer)
prim_round :: C_Float -> Result C_Int
prim_round x _ = toCurry (round x :: Integer)
prim_sqrt :: C_Float -> Result C_Float
prim_sqrt x _ = sqrt x
prim_log :: C_Float -> Result C_Float
prim_log x _ = log x
prim_exp :: C_Float -> Result C_Float
prim_exp x _ = exp x
prim_sin :: C_Float -> Result C_Float
prim_sin x _ = sin x
prim_cos :: C_Float -> Result C_Float
prim_cos x _ = cos x
prim_tan :: C_Float -> Result C_Float
prim_tan x _ = tan x
prim_atan :: C_Float -> Result C_Float
prim_atan x _ = atan x
......@@ -6,3 +6,293 @@
,ForFunction "nfIO"
,ForFunction "hnfIO"
,ForType "OrRef" Nothing]
import System.Mem.Weak ( addFinalizer )
import Control.Concurrent
import System.IO.Unsafe ( unsafeInterleaveIO )
import Debug.Trace ( trace )
import Data.List
data C_OrRef = C_OrRef OrRef
| C_OrRefFail Curry.RunTimeSystem.C_Exceptions
| C_OrRefOr Curry.RunTimeSystem.OrRef (Curry.RunTimeSystem.Branches C_OrRef)
instance BaseCurry C_OrRef where
nf f x state = f(x)(state)
gnf f x state = f(x)(state)
generator _ = error "free Variable of type OrRef"
failed = C_OrRefFail
branching = C_OrRefOr
consKind (C_OrRefOr _ _) = Curry.RunTimeSystem.Branching
consKind (C_OrRefFail _) = Curry.RunTimeSystem.Failed
consKind _ = Curry.RunTimeSystem.Val
exceptions (C_OrRefFail x) = x
orRef (C_OrRefOr x _) = x
branches (C_OrRefOr _ x) = x
instance Curry C_OrRef where
strEq (C_OrRef x1) (C_OrRef y1) _
= if x1 Prelude.== y1 then strEqSuccess else strEqFail "OrRef"
strEq x0 _ _ = Curry.Module.Prelude.strEqFail(Curry.Module.Prelude.typeName(x0))
eq (C_OrRef x1) (C_OrRef y1) _ =
if x1 Prelude.== y1 then C_True else C_False
eq _ _ _ = C_False
typeName _ = "OrRef"
propagate _ o _ = o
foldCurry _ c _ _ = c
showQ d (C_OrRef x1) = showParen (d>10) (showString "Unsafe.OrRef" . showsPrec d x1)
instance Show C_OrRef where
showsPrec d (C_OrRef x1) = showParen (d>10) (showString "OrRef" . showsPrec d x1)
instance Read C_OrRef where
readsPrec d r = [ (C_OrRef ref,s) | (ref,s) <- readsPrec d r]
---------------------------------------------------------------------------------
-- test for free variable
---------------------------------------------------------------------------------
prim_isFree :: (Curry t0) => t0 -> Result (C_IO (C_Either t0 t0))
prim_isFree x _ = C_IO (\ _ -> case consKind x of
Branching -> Prelude.return (IOVal (if isGenerator (orRef x)
then C_Left x
else C_Right x))
_ -> Prelude.return (IOVal (C_Right x)))
---------------------------------------------------------------------------------
-- various normal forms in io monad
---------------------------------------------------------------------------------
-- yield head normal form with current state
-- (including fetching and looking up variable bindings)
-- then apply continuation on it and make sure that you got a value
-- of type io before finally executing that action.
headNormalFormIO :: (Curry a,Curry b) => Prim (a -> Result (C_IO b)) -> a -> Result (C_IO b)
headNormalFormIO cont x _ =
C_IO (hnfCTC (\ x' st -> hnfCTC exec2 (apply cont x' st) st) x)
searchTree :: Curry a => a -> Result (C_SearchTree a)
searchTree = searchTr
hnfIO x _ = C_IO (hnfCTC (\ x _ -> Prelude.return (IOVal x)) x)
nfIO x _ = C_IO (nfCTC (\ x _ -> Prelude.return (IOVal x)) x)
gnfIO x _ = C_IO (ghnfCTC (\ x _ -> Prelude.return (IOVal x)) x)
ghnfIO x _ = C_IO (ghnfCTC (\ x _ -> Prelude.return (IOVal x)) x)
---------------------------------------------------------------------------------
-- rich search trees
---------------------------------------------------------------------------------
getRichSearchTree :: Curry a => a -> Result (C_IO (C_RichSearchTree a))
getRichSearchTree x _ = C_IO (\ state -> Prelude.return (IOVal (richSearchTr x state)))
richSearchTree :: Curry a => a -> Result (C_RichSearchTree a)
richSearchTree = richSearchTr
--inject :: Curry a => C_Context -> a -> C_RichSearchTree a
--inject (Context c) = richSearchTr c
richSearchTr :: Curry a => a -> Result (C_RichSearchTree a)
richSearchTr x state =
transVal (nfCTC (nfCTC (\ x _ -> x)) x state)
where
transVal x = case consKind x of
Val -> C_RichValue x
Failed -> C_RichFail (toCurry (exceptions x))
Branching -> transBranching (orRef x) (branches x)
transBranching _ [] = C_RichFail (C_ErrorCall List)
transBranching _ [x] = transVal x
transBranching r xs@(_:_:_) = C_RichChoice (C_OrRef r)
(fromHaskellList (map transVal xs))
instance ConvertCH C_Exception Exception where
toCurry (ErrorCall s) = C_ErrorCall (toCurry s)
toCurry (PatternMatchFail s) = C_PatternMatchFail (toCurry s)
toCurry (AssertionFailed s) = C_AssertionFailed (toCurry s)
toCurry (IOException s) = C_IOException (toCurry s)
toCurry PreludeFailed = C_PreludeFailed
fromCurry (C_ErrorCall s) = ErrorCall (fromCurry s)
fromCurry (C_PatternMatchFail s) = PatternMatchFail (fromCurry s)
fromCurry (C_AssertionFailed s) = AssertionFailed (fromCurry s)
fromCurry (C_IOException s) = IOException (fromCurry s)
fromCurry C_PreludeFailed = PreludeFailed
---------------------------------------------------------------------------------
-- parallel search
---------------------------------------------------------------------------------
parallelSearch :: Curry a => a -> Result (C_IO (List a))
parallelSearch v _ = C_IO (\state -> do
chan <- newChan
mvar <- newEmptyMVar
qsem <- newMyQSem 0
tid <- forkIO (searchThread qsem mvar chan
(nfCTC (nfCTC (\ x _ -> x)) v state))
putMVar mvar [tid]
--addFinalizer res (stopSearch mvar2)
res <- myGetChanContents qsem chan
Prelude.return (IOVal (fromHaskellList res)))
myGetChanContents :: Show a => MyQSem -> Chan (Maybe a) -> IO [a]
myGetChanContents qsem chan =
unsafeInterleaveIO ( do
decMyQSem qsem
x <- readChan chan
case x of
Nothing -> Prelude.return []
Just y -> do
xs <- myGetChanContents qsem chan
Prelude.return (y:xs) )
stopSearch :: MVar [ThreadId] -> IO ()
stopSearch mvar = do
print "start"
ids <- takeMVar mvar
mapM_ killThread ids
--putMVar mvar []
removeId :: MVar [ThreadId] -> Chan (Maybe a) -> ThreadId -> IO ()
removeId mvar chan tid = do
ids <- takeMVar mvar
let newids = delete tid ids
case newids of
[] -> writeChan chan Nothing -- >> putMVar mvar []
_ -> putMVar mvar newids
searchThread :: Curry a => MyQSem -> MVar [ThreadId] -> Chan (Maybe a)
-> a -> IO ()
searchThread qsem mvar chan x = do
case consKind x of
Val -> incMyQSem qsem >> writeChan chan (Just x) >> terminate
Failed -> terminate
Branching -> do
--yield
testMyQSem qsem
let b:bs = branches x
-- to prevent the threads from terminating till their Ids are registered
ids <- takeMVar mvar
newIds <- mapM (forkIO . searchThread qsem mvar chan) bs
putMVar mvar (newIds++ids)
searchThread qsem mvar chan b
where
noThreads = do
ids <- takeMVar mvar
putStrLn ("noThreads: " ++ show (length ids))
putMVar mvar ids
terminate = do
tid <- myThreadId
removeId mvar chan tid
newtype MyQSem = MyQSem (MVar (Int, [MVar ()]))
-- |Build a new 'MyQSem'
newMyQSem :: Int -> IO MyQSem
newMyQSem init = do
sem <- newMVar (init,[])
Prelude.return (MyQSem sem)
-- |Wait for a unit to become available
incMyQSem :: MyQSem -> IO ()
incMyQSem (MyQSem sem) = do
(avail,blocked) <- takeMVar sem
putMVar sem (avail+1,blocked)
-- |Signal that a unit of the 'MyQSem' is available
decMyQSem :: MyQSem -> IO ()
decMyQSem (MyQSem sem) = do
(avail,blocked) <- takeMVar sem
if avail>0 then putMVar sem (avail-1,blocked)
else mapM_ (flip putMVar ()) blocked >> putMVar sem (avail-1,[])
testMyQSem :: MyQSem -> IO ()
testMyQSem (MyQSem sem) = do
x@(avail,blocked) <- takeMVar sem
if avail<0 then putMVar sem x
else do
block <- newEmptyMVar
putMVar sem (avail,block:blocked)
takeMVar block
-------------------------------
-- covering non-determinism
-------------------------------
cover :: Curry a => a -> Result a
cover x st = case consKind x of
Branching -> branching (Curry.RunTimeSystem.cover (orRef x))
(map (flip Curry.Module.Meta.cover st) (branches x))
_ -> x
-----------------------------------
-- encapsulate to head normal form
-----------------------------------
st :: Curry a => a -> Result (C_SearchTree a)
st x s = transVal (hnfCTC (\ x _ -> x) x s)
where
transVal x = case consKind x of
Val -> C_Value x
Failed -> C_Fail
Branching -> let ref = orRef x in
if isCovered ref
then C_SearchTreeOr (uncover ref) (map (flip st s) (branches x))
else C_Choice (fromHaskellList (map transVal (branches x)))
-----------------------------------
-- encapsulate to head normal form
-----------------------------------
richST :: Curry a => a -> Result (C_RichSearchTree a)
richST x s = transVal (hnfCTC (\ x _ -> x) x s)
where
transVal x = case consKind x of
Val -> C_RichValue x
Failed -> C_RichFail (toCurry (exceptions x))
Branching -> let ref = orRef x in
if isCovered ref
then C_RichSearchTreeOr (uncover ref)
(map (flip richST s) (branches x))
else C_RichChoice (C_OrRef (orRef x))
(fromHaskellList (map transVal (branches x)))
-----------------------------
-- the general question mark
-----------------------------
ors :: Curry a => List a -> Result a
ors xs _ = branching (error "Unsafe.ors") (toHaskellList xs)
-- temporarily added
prim_throw :: Curry a => C_Exception -> Result a
prim_throw e _ = Curry.RunTimeSystem.failed (fromCurry e)
[ForFunction "prim_split",ForFunction "prim_nextInt",ForFunction "prim_nextIntRange",ForFunction "getRandomSeed"]
[ForFunction "prim_split"
,ForFunction "prim_nextInt"
,ForFunction "prim_nextIntRange"
,ForFunction "getRandomSeed"
]
import System.Random
prim_split :: C_Int -> Result (T2 C_Int C_Int)
prim_split seed _ = toCurry (fst (next g1), fst (next g2))
where
(g1,g2) = split (mkStdGen (fromCurry seed))
prim_nextInt :: C_Int -> Result (List C_Int)