Commit 60e792b5 authored by Bernd Brassel's avatar Bernd Brassel
Browse files

some external modules compiling

parent 2e7ea4cb
Name: KiCS
Version: 0.8.4
Version: 0.8.5
Cabal-Version: >= 1.6
Author: Bernd Braßel
Maintainer: Bernd Braßel
......@@ -12,7 +12,7 @@ Synopsis: A compiler from Curry to Haskell
Description: This package builds two binaries, kics and kicsi, respectively.
The first is the Curry to Haskell compiler, the latter a text
based interactive environment.
Stability: experimental
Stability: *INCOMPLETE* do not download yet! (sorry...)
Executable kics
main-is: kics.hs
......@@ -25,7 +25,7 @@ Executable kics
old-time,
directory,
containers,
curry-base >= 0.2.4,
curry-base >= 0.2.4
Other-Modules:
Config
CurryToHaskell
......@@ -39,12 +39,13 @@ Executable kics
Simplification
Brace
InstallDir
MyReadline
Executable kicsi
main-is: kicsi.hs
hs-source-dirs: src
Build-Depends:
base == 4.1.*,
base >= 4.1.0.0,
haskell98,
old-time,
filepath,
......@@ -67,6 +68,3 @@ Executable kicsi
Brace
InstallDir
MyReadline
Library
Exposed-Modules: Curry.Module.Prelude
\ No newline at end of file
module Config (module Config,module KicsSubdir) where
import System.FilePath
import System.Time (ClockTime)
import InstallDir
import SafeCalls
......@@ -406,18 +407,28 @@ put :: Int -> Options -> String -> Safe IO ()
put i Opts{verbosity=j} s | i>j = return ()
| i<=j = safeIO (putStrLn s)
readExternalSpec :: Options -> String -> Safe IO Options
readExternalSpec opts p = do
getExternalSpecFileName :: Options -> String -> Safe IO (Maybe FilePath)
getExternalSpecFileName opts p = do
specs <- safeIO $ findFileInPath
(externalSpecName (p `withoutSubdir` currySubdir))
(libpath opts)
if null specs
then return opts
else do
spec <- warning "" "" specs >>= safeIO . readModule
(libpath opts)
if null specs
then return Nothing
else warning "" "" specs >>= return . Just
readExternalSpec :: Options -> String -> Safe IO Options
readExternalSpec opts p = do
mspecFile <- getExternalSpecFileName opts p
case mspecFile of
Nothing -> return opts
Just specFile -> do
spec <- safeIO (readModule specFile)
put 5 opts "reading external specification"
let [(specs,stringToInclude)] = reads spec
newOpts = foldr insertP opts{toInclude=stringToInclude} specs
newOpts = foldr insertP
opts{toInclude=stringToInclude}
specs
safeIO (seq newOpts (return ()))
put 5 opts "external specification read"
return newOpts
......@@ -427,6 +438,13 @@ readExternalSpec opts p = do
insertP (ForType t Nothing) opts = opts{extData = t : extData opts}
insertP (ForType t (Just is)) opts = opts{extInsts = (t,is) : extInsts opts}
getExternalSpecModTime :: Options -> String -> Safe IO ClockTime
getExternalSpecModTime opts p = do
mspecFile <- getExternalSpecFileName opts p
case mspecFile of
Nothing -> return (TOD 0 0)
Just specFile -> safeIO $ getModuleModTime specFile
baseName f = case reverse f of
'y':'r':'r':'u':'c':'.':f' -> reverse f'
......
......@@ -2,8 +2,8 @@ module CurryToHaskell where
import List
import Char
import System
import System.FilePath
import System
import System.FilePath
import MetaProgramming.FlatCurry
import MetaProgramming.FlatCurryGoodies hiding (consName)
......@@ -15,7 +15,7 @@ import Maybe
import SafeCalls
import Brace
import Config
import Names (modName,dbgModName,funcHsName,
import Names (modName,dbgModName,funcHsName,externalSpecName,
elimInfix,funName,functionName,constructorName)
import qualified Names as N
import Monad
......@@ -122,9 +122,11 @@ getFlatCurryFileName opts@(Opts{filename=basename}) = do
return (opts{filename=foundBasename})
notUptodate opts@(Opts{filename=foundBasename}) = do
tSource <- getModTime (replaceExtension foundBasename ".fcy")
tDestination <- getModTime (funcHsName foundBasename)
return (tSource > tDestination)
tSource1 <- getModTime (replaceExtension foundBasename ".fcy")
tSource2 <- getExternalSpecModTime opts foundBasename
let destination = inModuleSubdir (inKicsSubdir (funcHsName foundBasename))
tDestination <- getModTime destination
return (tSource1 > tDestination || tSource2 > tDestination)
applyFlatTransformations opts prog = do
let auxNames = generateAuxNames (progFuncs prog)
......@@ -141,7 +143,7 @@ applyFlatTransformations opts prog = do
unless (null globals)
(put 5 opts
("module contains "++show (length globals)
++" global declarations"))
++" global declaration(s)"))
return (globals,liftedProg,interfaces,auxNames)
generateHaskellFiles opts (globals,prog,interfaces,auxNames) = do
......@@ -152,10 +154,11 @@ generateHaskellFiles opts (globals,prog,interfaces,auxNames) = do
return (haskellFiles opts (progName prog))
writeProgram opts (fn,unqualified,prog) = do
put 3 opts ("writing "++inKicsSubdir fn)
let fn' = inModuleSubdir (inKicsSubdir fn)
put 3 opts ("writing "++ fn')
let printOpts = defaultPrintOptions{unqual=unqualified,include=toInclude opts}
safeIO (writeKicsFile True fn (showProgOpt printOpts prog))
put 3 opts (fn++" written")
safeIO (writeKicsFile (fn/="Main.hs") fn (showProgOpt printOpts prog))
put 3 opts (fn'++" written")
return fn
......
......@@ -75,17 +75,21 @@ pathWithSubdirs = concatMap dirWithSubdirs
inKicsSubdir :: String -> String
inKicsSubdir s = inCurrySubdir s `inSubdir` kicsSubdir
inModuleSubdir :: String -> String
inModuleSubdir s = s `inSubdir` "Curry" `inSubdir` "Module"
--write a file to curry subdirectory
writeKicsFile :: Bool -> String -> String -> IO String
writeKicsFile isHsModule filename contents = do
let filename' | isHsModule = inKicsSubdir filename `inSubdir` "Curry" `inSubdir` "Module"
let filename' | isHsModule = inModuleSubdir (inKicsSubdir filename)
| otherwise = inKicsSubdir filename
subdir = dirname filename'
createDirectoryIfMissing True subdir
writeFile filename' contents
return filename'
-- do things with file in subdir
onExistingFileDo :: (String -> IO a) -> String -> IO a
......
[ForFunction "prim_doesFileExist",ForFunction "prim_doesDirectoryExist",ForFunction "prim_fileSize",ForFunction "prim_getModificationTime",ForFunction "prim_getDirectoryContents"]
\ No newline at end of file
[ForFunction "prim_doesFileExist"
,ForFunction "prim_doesDirectoryExist"
,ForFunction "prim_fileSize"
,ForFunction "prim_getModificationTime"
,ForFunction "prim_getDirectoryContents"
]
import System.Time
import System.Directory
import System.IO
prim_doesFileExist :: C_String -> Result (C_IO C_Bool)
prim_doesFileExist = ioFunc1 doesFileExist
prim_doesDirectoryExist :: C_String -> Result (C_IO C_Bool)
prim_doesDirectoryExist = ioFunc1 doesDirectoryExist
prim_fileSize :: C_String -> Result (C_IO C_Int)
prim_fileSize = ioFunc1 (\s->do h <- openFile s ReadMode
i <- hFileSize h
hClose h
Prelude.return i)
prim_getModificationTime :: C_String -> Result (C_IO C_ClockTime)
prim_getModificationTime = ioFunc1 getModificationTime
prim_getDirectoryContents :: C_String -> Result (C_IO (List C_String))
prim_getDirectoryContents = ioFunc1 getDirectoryContents
getCurrentDirectory :: Result (C_IO C_String)
getCurrentDirectory = ioFunc0 System.Directory.getCurrentDirectory
prim_createDirectory :: C_String -> Result (C_IO T0)
prim_createDirectory = ioFunc1 createDirectory
prim_removeFile :: C_String -> Result (C_IO T0)
prim_removeFile = ioFunc1 removeFile
prim_setCurrentDirectory :: C_String -> Result (C_IO T0)
prim_setCurrentDirectory = ioFunc1 setCurrentDirectory
prim_removeDirectory :: C_String -> Result (C_IO T0)
prim_removeDirectory = ioFunc1 removeDirectory
prim_renameFile :: C_String -> C_String -> Result (C_IO T0)
prim_renameFile = ioFunc2 renameFile
prim_renameDirectory :: C_String -> C_String -> Result (C_IO T0)
prim_renameDirectory = ioFunc2 renameDirectory
\ No newline at end of file
module ExternalDataGlobal (module ExternalDataGlobal) where
import Curry
import CurryPrelude
import Data.IORef
type C_Global t0 = Prim (IORef t0)
module ExternalDataIO (module ExternalDataIO) where
import Curry
import CurryPrelude
import System.IO
-- somehow using an either type did not get the curry class for prim through.
data IOHandle = One Handle | Two Handle Handle deriving (Show,Eq)
type C_Handle = Prim IOHandle
inputHandle, outputHandle :: IOHandle -> Handle
inputHandle (One h) = h
inputHandle (Two h _) = h
outputHandle (One h) = h
outputHandle (Two _ h) = h
instance Read IOHandle where
readsPrec = error "reading Handle"
instance Generate IOHandle where
genFree = error "free variable of type IO-Handle"
maxArity _ = error "free variable of type IO-Handle"
module ExternalDataIOExts where
import Curry
import CurryPrelude
import Data.IORef
type C_IORef a = Prim (IORef a)
instance Show (IORef a) where
show _ = "IOREF"
instance Read (IORef a) where
readsPrec = error "reading IOREF"
instance Generate (IORef a) where
genFree = error "free variable of type IOExts.IORef"
maxArity _ = error "free variable of type IOExts.IORef"
module ExternalDataPrelude (module AutoGenerated1, module ExternalDataPrelude) where
import Curry
import AutoGenerated1
-----------------------------------------------------------------
-- curry number types
-----------------------------------------------------------------
type C_Float = Prim Float
-----------------------------------------------------------------
-- The curry IO monad
-----------------------------------------------------------------
data C_IO t0 = C_IO (State -> IO (IOVal t0))
| C_IOFail C_Exceptions
| C_IOOr OrRef (Branches (C_IO t0))
data IOVal t0 = IOVal t0
| IOValFail C_Exceptions
| IOValOr OrRef (Branches (IO (IOVal t0)))
data C_Bool = C_False
| C_True
| C_BoolFail Curry.C_Exceptions
| C_BoolOr Curry.OrRef (Curry.Branches C_Bool)
| C_BoolAnd [C_Bool]
data C_Char = C_Char !Char
| SearchChar C_Four C_Four C_Four C_Four
| C_CharFail C_Exceptions
| C_CharOr OrRef (Branches C_Char)
module ExternalFunctionsDirectory where
import Curry
import CurryPrelude hiding (return)
import CurryTime
import System.Time
import System.Directory
import System.IO
prim_doesFileExist :: C_String -> Result (C_IO C_Bool)
prim_doesFileExist = ioFunc1 doesFileExist
prim_doesDirectoryExist :: C_String -> Result (C_IO C_Bool)
prim_doesDirectoryExist = ioFunc1 doesDirectoryExist
prim_fileSize :: C_String -> Result (C_IO C_Int)
prim_fileSize = ioFunc1 (\s->do h <- openFile s ReadMode
i <- hFileSize h
hClose h
return i)
prim_getModificationTime :: C_String -> Result (C_IO C_ClockTime)
prim_getModificationTime = ioFunc1 getModificationTime
prim_getDirectoryContents :: C_String -> Result (C_IO (List C_String))
prim_getDirectoryContents = ioFunc1 getDirectoryContents
getCurrentDirectory :: Result (C_IO C_String)
getCurrentDirectory = ioFunc0 System.Directory.getCurrentDirectory
prim_createDirectory :: C_String -> Result (C_IO T0)
prim_createDirectory = ioFunc1 createDirectory
prim_removeFile :: C_String -> Result (C_IO T0)
prim_removeFile = ioFunc1 removeFile
prim_setCurrentDirectory :: C_String -> Result (C_IO T0)
prim_setCurrentDirectory = ioFunc1 setCurrentDirectory
prim_removeDirectory :: C_String -> Result (C_IO T0)
prim_removeDirectory = ioFunc1 removeDirectory
prim_renameFile :: C_String -> C_String -> Result (C_IO T0)
prim_renameFile = ioFunc2 renameFile
prim_renameDirectory :: C_String -> C_String -> Result (C_IO T0)
prim_renameDirectory = ioFunc2 renameDirectory
\ No newline at end of file
module ExternalFunctionsGlobal (module ExternalFunctionsGlobal) where
import Curry
import CurryPrelude
import ExternalFunctionsIOExts
import InstancesGlobal
import Data.IORef
import System.IO.Unsafe
global :: (Curry t0) => t0 -> C_GlobalSpec -> Result (C_Global t0)
global x spec = ref `seq` (\ _ -> PrimValue ref)
where ref = unsafePerformIO (Data.IORef.newIORef x)
prim_readGlobal :: (Curry t0) => C_Global t0 -> Result (C_IO t0)
prim_readGlobal = prim_readIORef
prim_writeGlobal :: (Curry t0) => C_Global t0 -> t0 -> Result (C_IO T0)
prim_writeGlobal = prim_writeIORef
module ExternalFunctionsIO where
import Curry
import CurryPrelude hiding (return,(>>=))
import InstancesIO
import qualified System.IO as SI
import Control.Concurrent
import qualified Control.Exception as CE
instance ConvertCH C_IOMode SI.IOMode where
toCurry SI.ReadMode = C_ReadMode
toCurry SI.WriteMode = C_WriteMode
toCurry SI.AppendMode = C_AppendMode
fromCurry C_ReadMode = SI.ReadMode
fromCurry C_WriteMode = SI.WriteMode
fromCurry C_AppendMode = SI.AppendMode
instance ConvertCH C_SeekMode SI.SeekMode where
toCurry SI.AbsoluteSeek = C_AbsoluteSeek
toCurry SI.RelativeSeek = C_RelativeSeek
toCurry SI.SeekFromEnd = C_SeekFromEnd
fromCurry C_AbsoluteSeek = SI.AbsoluteSeek
fromCurry C_RelativeSeek = SI.RelativeSeek
fromCurry C_SeekFromEnd = SI.SeekFromEnd
stdin :: Result C_Handle
stdin _ = PrimValue (One SI.stdin)
stdout :: Result C_Handle
stdout _ = PrimValue (One SI.stdout)
stderr :: Result C_Handle
stderr _ = PrimValue (One SI.stderr)
prim_openFile :: List C_Char -> C_IOMode -> Result (C_IO C_Handle)
prim_openFile = ioFunc2 (\ s m -> do
h <- SI.openFile s m
return (One h))
prim_hClose :: C_Handle -> Result (C_IO T0)
prim_hClose = ioFunc1 (\ eh -> case eh of
One h -> SI.hClose h
Two h1 h2 -> SI.hClose h1 >> SI.hClose h2)
prim_hFlush :: C_Handle -> Result (C_IO T0)
prim_hFlush = ioFunc1 (SI.hFlush . outputHandle)
prim_hIsEOF :: C_Handle -> Result (C_IO C_Bool)
prim_hIsEOF = ioFunc1 (SI.hIsEOF . inputHandle)
prim_hSeek :: C_Handle -> C_SeekMode -> C_Int -> Result (C_IO T0)
prim_hSeek = ioFunc3 (\ h -> SI.hSeek (inputHandle h))
prim_hWaitForInput :: C_Handle -> C_Int -> Result (C_IO C_Bool)
prim_hWaitForInput = ioFunc2 (\ h -> myhWaitForInput (inputHandle h))
myhWaitForInput :: SI.Handle -> Int -> IO Bool
myhWaitForInput h i =
if i < 0
then SI.hIsEOF h >>= return . not
else SI.hWaitForInput h i
selectHandle :: [IOHandle] -> Int -> IO Int
selectHandle handles t = do
mvar <- newEmptyMVar
threads <- mapM (\ (i,h) -> forkIO (waitOnHandle (inputHandle h) i t mvar))
(zip [0..] handles)
inspectRes (length handles) mvar threads
inspectRes :: Int -> MVar (Maybe Int) -> [ThreadId] -> IO Int
inspectRes 0 _ _ = return (-1)
inspectRes n mvar threads = do
res <- readMVar mvar
case res of
Nothing -> inspectRes (n-1) mvar threads
Just v -> mapM_ killThread threads >> return v
waitOnHandle :: SI.Handle -> Int -> Int -> MVar (Maybe Int) -> IO ()
waitOnHandle h v t mvar = do
ready <- myhWaitForInput h t
putMVar mvar (if ready then Just v else Nothing)
prim_hWaitForInputs :: List C_Handle -> C_Int -> Result (C_IO C_Int)
prim_hWaitForInputs = ioFunc2 selectHandle
prim_hGetChar :: C_Handle -> Result (C_IO C_Char)
prim_hGetChar = ioFunc1 (SI.hGetChar . inputHandle)
prim_hPutChar :: C_Handle -> C_Char -> Result (C_IO T0)
prim_hPutChar = ioFunc2 (SI.hPutChar . outputHandle)
prim_hIsReadable :: C_Handle -> Result (C_IO C_Bool)
prim_hIsReadable = ioFunc1 (SI.hIsReadable . inputHandle)
prim_hIsWritable :: C_Handle -> Result (C_IO C_Bool)
prim_hIsWritable = ioFunc1 (SI.hIsWritable . outputHandle)
module ExternalFunctionsIOExts where
import Curry
import CurryPrelude hiding (return,(>>=))
import CurryIO
import ExternalDataIOExts
import qualified Data.IORef as Ref
import System.Process
import Network
import qualified Network.Socket as SO
import System.IO.Unsafe
import Control.Concurrent
import System.IO
instance Eq (List C_Char) where
List == List = True
List == (_ :< _) = False
(_ :< _) == List = False
(C_Char c :< xs) == (C_Char c' :< ys) = c Prelude.== c' && xs Prelude.== ys
type Assocs = [(C_String,C_String)]
assocs :: Ref.IORef Assocs
assocs = unsafePerformIO (Ref.newIORef [])
getAssocs :: IO Assocs
getAssocs = Ref.readIORef assocs
setAssocs :: Assocs -> IO ()
setAssocs as = Ref.writeIORef assocs as
prim_execCmd :: List C_Char -> Result (C_IO (T3 C_Handle C_Handle C_Handle))
prim_execCmd = ioFunc1 (\s -> do
(h1,h2,h3,_) <- runInteractiveCommand s
return (One h1,One h2,One h3))
prim_connectToCmd :: List C_Char -> Result (C_IO C_Handle)
prim_connectToCmd = ioFunc1 (\s -> do
(hin,hout,herr,_) <- runInteractiveCommand s
forkIO (forwardError herr)
return (Two hout hin))
forwardError :: Handle -> IO ()
forwardError h = do
eof <- hIsEOF h
if eof then return ()
else hGetLine h >>= hPutStrLn System.IO.stderr >> forwardError h
prim_setAssoc :: List C_Char -> List C_Char -> Result (C_IO T0)
prim_setAssoc key val = ioFunc0 (do
as <- getAssocs
setAssocs ((key,val):as))
prim_getAssoc :: List C_Char -> Result (C_IO (C_Maybe (List C_Char)))
prim_getAssoc key _ = C_IO (\_ -> do
as <- getAssocs
return (IOVal (maybe C_Nothing C_Just (lookup key as))))
newIORef :: Curry t0 => t0 -> Result (C_IO (C_IORef t0))
newIORef x = ioFunc0 (Ref.newIORef x)
prim_readIORef :: Curry t0 => C_IORef t0 -> Result (C_IO t0)
prim_readIORef (PrimValue ref) _ =
C_IO (\ _ -> do
v <- Ref.readIORef ref
return (IOVal v))
prim_writeIORef :: Curry t0 => C_IORef t0 -> t0 -> Result (C_IO T0)
prim_writeIORef (PrimValue ref) x = ioFunc0 (Ref.writeIORef ref x)
{-# OPTIONS -cpp #-}
{-# LANGUAGE RankNTypes,
ScopedTypeVariables,
MultiParamTypeClasses,
FlexibleInstances #-}
module ExternalFunctionsPrelude where
import Prelude hiding ((==),(>>=),return,catch)
import qualified Prelude ((==),(>>=),return)
import Data.Char (ord,chr)
import Curry
import List
import DataPrelude
--import BaseCurry (op_61_58_61,op_38,op_61_61,c_error)
import System.IO.Unsafe
import System.IO
import InstancesPrelude
import Data.IORef
#if __GLASGOW_HASKELL__ >= 610
import Control.OldException (catch)
#else
import Control.Exception (catch)
#endif
infix 4 ===
infixr 0 &