diff --git a/Channel.hs b/Channel.hs --- a/Channel.hs +++ b/Channel.hs @@ -1,117 +1,128 @@ module Channel ( - Channel (..) , - ChannelType(..), stdChan , newChan , - dataBreak ) + newDummyChan , + serialisable , + getChannelData ) where -import qualified Network as N -import Network.BSD (getHostName) -import System.IO (Handle, hFlush, hGetLine, hPutStrLn, hShow) -import System.IO.Error (catchIOError) +import Control.Applicative ((<$>)) +import Control.Arrow (second) import Control.Concurrent (forkIO,threadDelay) import Control.Concurrent.MVar - -data Channel = Channel { - chanType :: ChannelType - , clientPort :: Integer - , send :: String -> IO () - , receive :: IO String - , extra :: [String] - } +import qualified Control.Concurrent.Chan as Ch +import Network.BSD (getHostName) +import qualified Network as N +import System.IO (BufferMode(..), Handle, hFlush, hGetLine, hPutStr, hPutStrLn, hReady, hSetBuffering) +import System.IO.Error (catchIOError) -data ChannelType = Internal - | Std - | HTTP - | String - deriving (Eq, Show, Read) +import TypDefs (Channel (..), BuildType (..)) stdChan :: Handle -> Channel -stdChan h = Channel Std (-1) write rd [] +stdChan h = Channel write rd [] where write = hPutStrLn h rd = hGetLine h -newChan :: ChannelType -> String -> Integer -> IO Channel -newChan t host cp = do - currentHost <- getHostName - case t of - Internal -> newInternalChan currentHost hostPort cp - HTTP - | hostName == "localhost" || hostName == currentHost -> newLocalChan t cp - | otherwise -> newForeignChan t hostName hostPort - String -> newForeignChan t hostName hostPort - where - (hostName, _:hostPort) = break (==':') host +newChan :: BuildType -> String -> Integer -> IO Channel +newChan t host port = + case t of + Init -> newChanServer port + Connect -> newChanClient host port -newInternalChan :: String -> String -> Integer -> IO Channel -newInternalChan hostName hostPort cp = return $ Channel Internal cp s r ex +newDummyChan :: IO Channel +newDummyChan = do + chan <- Ch.newChan + return $ Channel (Ch.writeChan chan) (Ch.readChan chan) [] + +{-newInternalChan :: String -> String -> Integer -> IO Channel +newInternalChan hostName hostPort cp = do + currentHost <- getHostName + let ex = makeExtra ["host","clientPort"] [currentHost ++ ":" ++ hostPort,show cp] + return $ Channel s r True ex where r = N.withSocketsDo $ do - inSock <- N.listenOn $ N.PortNumber $ fromIntegral cp - (inHandle,_,_) <- N.accept inSock - msg <- hGetLine inHandle - N.sClose inSock + sock <- N.listenOn $ N.PortNumber $ fromIntegral cp + (inHandle,_,_) <- N.accept sock + msg <- unlines <$> emptyHandle inHandle + putStrLn $ "got: " ++ msg + N.sClose sock return msg s v = N.withSocketsDo $ do _ <- forkIO $ do outHandle <- waitForConnect hostName $ N.PortNumber $ port hostPort - hPutStrLn outHandle v - return () - ex = zipWith (\a b -> (a ++ dataBreak : b)) ["host","clientPort","type"] [hostName ++ ":" ++ hostPort,show cp,show Internal] + putStrLn $ "sending: " ++ v + hPutStr outHandle v + return ()-} -newLocalChan :: ChannelType -> Integer -> IO Channel -newLocalChan t cp = N.withSocketsDo $ do +newChanServer :: Integer -> IO Channel +newChanServer cp = N.withSocketsDo $ do hanVar <- newEmptyMVar _ <- forkIO $ do - inSock <- N.listenOn $ N.PortNumber $ fromIntegral cp - (inHandle,_,_) <- N.accept inSock - putMVar hanVar inHandle + sock <- N.listenOn $ N.PortNumber $ fromIntegral cp + (clientHandle,_,_) <- N.accept sock + putMVar hanVar clientHandle currentHost <- getHostName - let ex' = ex ++ ["host" ++ dataBreak :currentHost ++ ":" ++ show cp] - return $ Channel t cp (send' hanVar) (receive' hanVar) ex' - where - ex = zipWith (\a b -> (a ++ dataBreak : b)) ["clientPort","type"] [show cp,show t] + let ex = makeExtra [hostSig,portSig] [currentHost, show cp] + return $ Channel (send' hanVar) (receive' hanVar) ex -newForeignChan :: ChannelType -> String -> String -> IO Channel -newForeignChan t hostName hostPort = N.withSocketsDo $ do +newChanClient :: String -> Integer -> IO Channel +newChanClient hostName hostPort = N.withSocketsDo $ do hanVar <- newEmptyMVar _ <- forkIO $ do - outHandle <- waitForConnect hostName $ N.PortNumber $ port hostPort - putMVar hanVar outHandle - return $ Channel t 0 (send' hanVar) (receive' hanVar) ex + serverHandle <- waitForConnect hostName $ N.PortNumber $ fromIntegral hostPort + putMVar hanVar serverHandle + return $ Channel (send' hanVar) (receive' hanVar) ex where - ex = zipWith (\a b -> a ++ dataBreak : b) ["host","clientPort","type"] [hostName ++ ":" ++ hostPort,"-1",show t] - -port :: String -> N.PortNumber -port s = fromIntegral (read s :: Integer) - -dataBreak :: Char -dataBreak = '#' + ex = makeExtra [hostSig, portSig] [hostName, show hostPort] waitForConnect :: N.HostName -> N.PortID -> IO Handle waitForConnect h p = N.connectTo h p `catchIOError` (\_ -> do - threadDelay 10000 + threadDelay 1000000 putStrLn "waiting for connection" waitForConnect h p) send' :: MVar Handle -> String -> IO () -send' hanVar v = do +send' hanVar msg = do han <- takeMVar hanVar - hPutStrLn han v - hFlush han + hPutStrLn han msg putMVar hanVar han receive' :: MVar Handle -> IO String receive' hanVar = do han <- readMVar hanVar - msg <- hGetLine han - hFlush han - return msg + unlines <$> emptyHandle han -printH :: Handle -> IO () -printH h = do - hstr <- hShow h - putStrLn hstr +emptyHandle :: Handle -> IO [String] +emptyHandle h = do + line <- hGetLine h + more <- hReady h `catchIOError` (\_ -> return False) + if more + then (line:) <$> emptyHandle h + else return [line] + +--lineBuffer :: Handle -> IO () +--lineBuffer h = hSetBuffering h LineBuffering + +dataBreak :: Char +dataBreak = '#' + +hostSig :: String +hostSig = "host" + +portSig :: String +portSig = "port" + +makeExtra :: [String] -> [String] -> [String] +makeExtra = zipWith (\a b -> (a ++ dataBreak : b)) + +serialisable :: Channel -> Bool +serialisable = not . null . extra + +getChannelData :: [String] -> Maybe (String, Integer) +getChannelData strs = do + let ex = map (second tail . break (==dataBreak)) strs + host <- lookup hostSig ex + port <- lookup portSig ex + return (host,read port) diff --git a/Parser.hs b/Parser.hs new file mode 100644 --- /dev/null +++ b/Parser.hs @@ -0,0 +1,227 @@ +module Parser ( + readTerm, + readProcess, + readProcesses) + where + +import Control.Monad (liftM) +import Control.Monad.Error (throwError) +import Text.ParserCombinators.Parsec + +import TypDefs (Condition (..), PiProcess (..), Term (..), Type(..), Value(..), Name, PiError(Parser), ThrowsError) + +parseNull :: Parser PiProcess +parseNull = char '0' >> return Null "parse null" + +parseIn :: Parser PiProcess +parseIn = do + _ <- string "in(" + name <- parseTerm + paddedComma + var <- parseTerm + _ <- char ')' + parseSeq $ In name var + "parse in" + +parseOut :: Parser PiProcess +parseOut = do + _ <- string "out(" + name <- parseTerm + paddedComma + term <- parseTerm + _ <- char ')' + parseSeq $ Out name term + "parse out" + +parseReplicate :: Parser PiProcess +parseReplicate = do + _ <- string "!(" + process <- parseProcess + _ <- char ')' + return $ Replicate process + "parse replicate" + +myOption :: Show b => a -> Parser a -> Parser b -> Parser a +myOption opt parser sep = try (notFollowedBy sep >> return opt) <|> (sep >> parser) + +myOptionMaybe :: Show b => Parser a -> Parser b -> Parser (Maybe a) +myOptionMaybe parser = myOption Nothing (liftM Just parser) + +parseSeq :: PiProcess -> Parser PiProcess +parseSeq p1 = do + p2 <- myOption Null parseProcess (paddedChar ';') + return $ p1 `Seq` p2 + +parseNew :: Parser PiProcess +parseNew = do + _ <- string "new" + spaces + name <- parseTerm + parseSeq $ New name + "parse new" + + +parseIf :: Parser PiProcess +parseIf = do + _ <- string "if" + spaces + cond <- parseCondition + paddedStr "then" + p1 <- parseProcess + p2 <- myOption Null parseProcess (paddedStr1 "else") + return $ If cond p1 p2 + "parse if" + +parseLet :: Parser PiProcess +parseLet = do + _ <- string "let" + spaces + name <- parseTerm + paddedChar1 '=' + val <- try (liftM Proc parseProcess) <|> liftM Term parseTerm + p <- myOptionMaybe parseProcess (paddedStr1 "in") + return $ Let name val p + "parse let" + +parseAtom :: Parser PiProcess +parseAtom = do + _ <- char '&' + atom <- parseTerm + parseSeq $ Atom atom + +padded1 :: Parser a -> Parser () +padded1 p = do + skipMany1 space + _ <- p + skipMany1 space + +paddedChar :: Char -> Parser () +paddedChar ch = padded $ char ch + +paddedStr :: String -> Parser () +paddedStr str = padded $ string str + +padded :: Parser a -> Parser () +padded p = do + spaces + _ <- p + spaces + +paddedChar1 :: Char -> Parser () +paddedChar1 ch = padded1 $ char ch + +paddedStr1 :: String -> Parser () +paddedStr1 str = padded1 $ string str + +paddedComma :: Parser () +paddedComma = paddedChar ',' + +parseCondition :: Parser Condition +parseCondition = do + t1 <- parseTerm + paddedChar1 '=' + t2 <- parseTerm + return $ t1 `Equals` t2 + +parseTVar :: Parser Term +parseTVar = do + v <- readVar + case v of + "true" -> return $ TBool True + "false" -> return $ TBool False + _ -> do + t <- myOptionMaybe parseType (paddedChar ':') + return $ TVar v t + +parseTFun :: Parser Term +parseTFun = do + name <- readVar + spaces + args <- bracketed $ sepBy parseTerm paddedComma + return $ case (name,args) of + ("pair", t1:t2:_) -> TPair (t1,t2) + ("list", _ ) -> TList args + _ -> TFun name args + +parseTStr :: Parser Term +parseTStr = do + _ <- char '"' + x <- many $ noneOf "\"" + _ <- char '"' + return $ TStr x + +parseTNum :: Parser Term +parseTNum = liftM (TNum . read) (many1 digit) + +readVar :: Parser Name +readVar = do + frst <- letter <|> symbol + rest <- many $ letter <|> digit <|> symbol + return $ frst:rest + +symbol :: Parser Char +symbol = oneOf "'._<>" + +parseTerm :: Parser Term +parseTerm = try parseAnonChan + <|> try parseTFun + <|> parseTNum + <|> parseTVar + <|> parseTStr + where + parseAnonChan = do + _ <- char '{' + spaces + arg <- many parseTerm + spaces + _ <- char '}' + return $ TFun "anonChan" arg + +parseProcesses :: Parser [PiProcess] +parseProcesses = sepEndBy parseProcess newline + +parseProcess :: Parser PiProcess +parseProcess = liftM (\ps -> case ps of + [p] -> p + _ -> Conc ps) $ sepBy1 parseProcess' (char '|') + where + parseProcess' = bracketed parseProcess'' <|> parseProcess'' + parseProcess'' = parseNull + <|> try parseIf + <|> parseIn + <|> parseOut + <|> parseLet + <|> parseReplicate + <|> parseNew + <|> parseAtom + + + +parseType :: Parser Type +parseType = try (str HttpRequest) + <|> try (str HttpResponse) + <|> try (str Header) + <|> parseListType + where + str t = string (show t) >> return t + parseListType = string "List" >> many1 space >> fmap List parseType + + +bracketed :: Parser a -> Parser a +bracketed = between (char '(') (char ')') + +readOrThrow :: Parser a -> String -> String -> ThrowsError a +readOrThrow parser name input = case parse parser name input of + Left err -> throwError $ Parser err + Right val -> return val + +readProcess :: String -> ThrowsError PiProcess +readProcess = readOrThrow parseProcess "single process" + +readProcesses :: String -> ThrowsError [PiProcess] +readProcesses = readOrThrow parseProcesses "multiple-processes" + +readTerm :: String -> ThrowsError Term +readTerm str = case parse parseTerm "term" str of + Left err -> throwError $ Parser err + Right val -> return val diff --git a/PatternMatching.hs b/PatternMatching.hs new file mode 100644 --- /dev/null +++ b/PatternMatching.hs @@ -0,0 +1,42 @@ +module PatternMatching (match) where + +import Control.Arrow (second) +import Control.Monad (liftM,liftM2,zipWithM) +import Control.Monad.Error (throwError) +import TypDefs +import Parser () +import Network.HTTP.Base + +match :: Term -> Term -> ThrowsError [(String,Value)] +match a b = liftM (map (second Term)) $ match' a b + +match' :: Term -> Term -> ThrowsError [(String,Term)] +match' (TVar name _) term = return [(name,term)] +match' (TPair (m1, m2)) (TPair (t1,t2)) = liftM2 (++) (match' m1 t1) (match' m2 t2) +match' (TList ms) (TList ts) = liftM concat $ zipWithM match' ms ts +match' l@(TList _) (TData d) = match' l $ dataToList d +match' t1 t2 = throwError $ PatternMatch t1 t2 + +dataToList :: HttpData -> Term +dataToList (Req r) = TList [TStr uri, TList headers, method] + where + uri = show $ rqURI r + headers = map (TStr . show) $ rqHeaders r + method = case rqMethod r of + HEAD -> TFun "httpHead" [] + GET -> TFun "httpGet" [] + POST -> TFun "httpPost" [] + _ -> TFun "httpGet" [] +dataToList (Resp r) = TList [TNum code, TStr reason, TList headers, TStr bdy] + where + code = let (x,y,z) = rspCode r in fromIntegral (100*x + 10* y + z) + reason = rspReason r + headers = map (TStr . show) $ rspHeaders r + bdy = rspBody r + +{-testMatch :: String -> String -> ThrowsError [(String,Term)] +testMatch s1 s2 = do + t1 <- readTerm s1 + t2 <- readTerm s2 + match' t1 t2-} + diff --git a/PiCalculus.hs b/PiCalculus.hs --- a/PiCalculus.hs +++ b/PiCalculus.hs @@ -1,69 +1,25 @@ -{-# LANGUAGE TupleSections #-} module Main where import Control.Arrow (second) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar) -import Control.Monad (liftM, liftM2, unless) -import Control.Monad.Error (throwError) +import Control.Monad (liftM, liftM2, unless, void) import Control.Monad.Trans (liftIO) -import Control.Monad.Trans.Except (ExceptT(..), catchE, runExceptT, throwE) -import Data.Char (toLower) -import Data.IORef (IORef, newIORef, readIORef,writeIORef) -import Data.List (intercalate) +import Control.Monad.Trans.Except (catchE, runExceptT, throwE) +import Data.IORef (newIORef, readIORef,writeIORef) import Data.Maybe (isJust) -import Network.HTTP.Base (Request(..), RequestMethod(..), mkRequest) -import Network.URI (parseURI) +import Network.HTTP.Base (Request(..),Response(..), parseResponseHead, parseRequestHead) import System.Environment (getArgs, getProgName) import System.IO (hFlush, stderr, stdin, stdout) -import Text.ParserCombinators.Parsec +import System.IO.Error (tryIOError) -import Data.Map (Map) import qualified Data.Map as Map import Channel - -data PiProcess = Null - | In Term Term - | Out Term Term - | New Term - | PiProcess `Seq` PiProcess -- Sequential Composition - | Conc [PiProcess] -- Parallel Composition - | Replicate PiProcess -- Infinite parallel replication - | Let Term Value (Maybe PiProcess) - | If Condition PiProcess PiProcess - deriving (Eq,Show) - -data Term = TVar Name - | TStr String - | TNum Integer - | TBool Bool - | TPair (Term, Term) - | TFun Name [Term] Int - deriving (Eq) - -data Value = Proc PiProcess - | Term Term - | Chan Channel - | PrimitiveFunc TermFun - | Func {params :: [String] , body :: Value, closure :: Env} - -data PiError = NumArgs Name Integer [Value] - | TypeMismatch String [Value] - | Parser ParseError - | UnboundVar String String - | NotTerm Name Value - | NotFunction String String - | NotChannel String - | Default String - -type IOThrowsError = ExceptT PiError IO -type ThrowsError = Either PiError - -type Name = String -data Condition = Term `Equals` Term deriving (Eq) - -type Env = IORef (Map String Value) +import Parser +import Primitives +import TypDefs +import PatternMatching nullEnv :: IO Env nullEnv = newIORef Map.empty @@ -78,6 +34,7 @@ (Map.lookup var env) setVar :: Env -> String -> Value -> IOThrowsError Value +setVar _ "_" _ = return $ Term $ TVar "_" Nothing -- to allow wildcard matching setVar envRef var val = do env <- liftIO $ readIORef envRef maybe (throwE $ UnboundVar "Setting an unbound variable" var) (return $ liftIO $ writeIORef envRef $ Map.insert var val env) @@ -94,229 +51,6 @@ writeIORef envRef $ Map.insert var val env return val -showValue :: Value -> String -showValue (Proc p) = show p -showValue (Term t) = show t -showValue (Chan c) = show $ convert c - where - convert ch = TFun "" (map TStr ex) $ length ex - where ex = extra ch -showValue (PrimitiveFunc _) = "" -showValue (Func {}) = "" - -eqvVal :: Value -> Value -> Bool -eqvVal (Proc p1) (Proc p2) = p1 == p2 -eqvVal (Term t1) (Term t2) = t1 == t2 -eqvVal _ _ = False - -instance Eq Value where (==) = eqvVal - -showPi :: PiProcess -> String -showPi Null = "0" -showPi (In c m) = "in(" ++ show c ++ "," ++ show m ++ ")" -showPi (Out c m) = "out(" ++ show c ++ "," ++ show m ++ ")" -showPi (Replicate proc) = "!(" ++ show proc ++ ")" -showPi (Conc procs) = intercalate "|" $ map show procs -showPi (p1 `Seq` Null) = show p1 -showPi (p1 `Seq` p2) = show p1 ++ ";" ++ show p2 -showPi (New n) = "new " ++ show n -showPi (If c p1 Null) = "if " ++ show c ++ " then " ++ show p1 -showPi (If c p1 p2) = "if " ++ show c ++ " then " ++ show p1 ++ " else " ++ show p2 -showPi (Let n t p) = "let " ++ show n ++ " = " ++ show t ++ case p of {Nothing -> "" ; Just x -> " in\n" ++ show x} - -showTerm :: Term -> String -showTerm (TVar x) = x -showTerm (TStr str) = "\"" ++ str ++ "\"" -showTerm (TNum num) = show num -showTerm (TBool b ) = map toLower $ show b -showTerm (TPair (a,b)) = "pair("++ show a ++ ","++ show b ++ ")" -showTerm (TFun n ts _ ) = n ++ "(" ++ intercalate "," (map show ts) ++ ")" - -showCond :: Condition -> String -showCond (t1 `Equals` t2) = show t1 ++ " == " ++ show t2 - -showError :: PiError -> String -showError (UnboundVar message var) = message ++ ": " ++ var -showError (NotFunction message fun) = message ++ ": " ++ fun -showError (NotChannel chan) = "Not a channel: " ++ chan -showError (NotTerm name var) = "Expecting " ++ name ++ " to be a Term, found: " ++ show var -showError (NumArgs name expected found) = "Expected " ++ show name ++ show expected ++ " args; found values " - ++ unwordsList found -showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " - ++ show found -showError (Parser parseErr) = "Parse error at " ++ show parseErr -showError (Default msg) = msg - ---instance Show PiProcess where show = showPi -instance Show Term where show = showTerm -instance Show Condition where show = showCond -instance Show Value where show = showValue -instance Show PiError where show = showError - -unwordsList :: [Value] -> String -unwordsList = unwords . map show - -parseNull :: Parser PiProcess -parseNull = do - paddedChar '0' - return Null - -parseIn :: Parser PiProcess -parseIn = do - _ <- string "in(" - name <- parseTerm - paddedComma - var <- parseTerm - _ <- char ')' - parseSeq $ In name var - -parseOut :: Parser PiProcess -parseOut = do - _ <- string "out(" - name <- parseTerm - paddedComma - term <- parseTerm - _ <- char ')' - parseSeq $ Out name term - -parseReplicate :: Parser PiProcess -parseReplicate = do - _ <- string "!(" - process <- parseProcess - _ <- char ')' - return $ Replicate process - -paddedChar :: Char -> Parser () -paddedChar ch = do - spaces - _ <- char ch - spaces - -paddedStr :: String -> Parser () -paddedStr str = do - spaces - _ <- string str - spaces - -parseSeq :: PiProcess -> Parser PiProcess -parseSeq p1 = do - p2 <- try (do {paddedChar ';' ; parseProcess}) <|> return Null - return $ p1 `Seq` p2 - -parseNew :: Parser PiProcess -parseNew = do - _ <- string "new" - spaces - name <- parseTerm - parseSeq $ New name - -parseIf :: Parser PiProcess -parseIf = do - _ <- string "if" - spaces - cond <- parseCondition - paddedStr "then" - p1 <- parseProcess - p2 <- try (do {paddedStr "else" ; parseProcess}) <|> return Null - return $ If cond p1 p2 - -parseLet :: Parser PiProcess -parseLet = do - _ <- string "let" - spaces - name <- parseTerm - paddedChar '=' - val <- liftM Term parseTerm <|> liftM Proc parseProcess - p <- try (do - paddedStr "in" - proc <- parseProcess - return $ Just proc) <|> return Nothing - return $ Let name val p - -parseCondition :: Parser Condition -parseCondition = do - t1 <- parseTerm - paddedChar '=' - t2 <- parseTerm - return $ t1 `Equals` t2 - -parseTVar :: Parser Term -parseTVar = do - v <- readVar - return $ case v of - "true" -> TBool True - "false" -> TBool False - _ -> TVar v - -parseTFun :: Parser Term -parseTFun = do - name <- readVar - spaces - args <- bracketed $ sepBy parseTerm paddedComma - return $ case (name,args) of - ("pair", t1:t2:_) -> TPair (t1,t2) - _ -> TFun name args (length args) - -parseTStr :: Parser Term -parseTStr = do - _ <- char '"' - x <- many $ noneOf "\"" - _ <- char '"' - return $ TStr x - -parseTNum :: Parser Term -parseTNum = liftM (TNum . read) (many1 digit) - -readVar :: Parser Name -readVar = do - frst <- letter <|> symbol - rest <- many $ letter <|> digit <|> symbol - return $ frst:rest - -symbol :: Parser Char -symbol = oneOf "'._<>" - -paddedComma :: Parser () -paddedComma = paddedChar ',' - -parseTerm :: Parser Term -parseTerm = try parseAnonChan - <|> try parseTFun - <|> parseTNum - <|> parseTVar - <|> parseTStr - where - parseAnonChan = do - paddedChar '(' - arg <- many digit - paddedChar ')' - case arg of - [] -> return $ TFun "anonChan" [] 0 - _ -> return $ TFun "anonChan" [TNum (read arg)] 1 - -parseProcess :: Parser PiProcess -parseProcess = liftM Conc $ sepBy parseProcess' (paddedChar '|') - where - parseProcess' = bracketed parseProcess'' <|> parseProcess'' - parseProcess'' = parseNull - <|> try parseIf - <|> parseIn - <|> parseOut - <|> parseReplicate - <|> parseNew - <|> parseLet - -bracketed :: Parser a -> Parser a -bracketed parser = do - _ <- char '(' - spaces - res <- parser - spaces - _ <- char ')' - return res - -type TermFun = [Term] -> ThrowsError Term - bindVars :: Env -> [(String , Value)] -> IO Env bindVars envRef bindings = do env <- readIORef envRef @@ -327,94 +61,22 @@ n <- nullEnv e1 <- bindVars n (map (second PrimitiveFunc) primitives) e2 <- bindVars e1 (map (second Chan) nativeChannels) - bindVars e2 [(counterRef, Term $ TNum lowestPort)] + net <- newDummyChan + bindVars e2 [(counterRef, Term $ TNum lowestPort), + ("localnet" , Chan net)] where lowestPort = 2^(15::Integer) + 2^(14::Integer) + counterRef :: String counterRef = "###" - nativeChannels :: [(String , Channel)] nativeChannels = [ ("stdin" , stdChan stdin) - , ("0" , stdChan stdin) , ("stdout" , stdChan stdout) - , ("1" , stdChan stdout) , ("stderr" , stdChan stderr) - , ("2" , stdChan stderr) ] -primitives :: [(String , TermFun)] -primitives = [ ("fst" , first) - , ("snd" , secnd) - , ("hash" , unaryId "hash") - , ("pk" , unaryId "pk") - , ("httpRequest", http) - , ("getmsg" , getmsg) - , ("pair" , binaryId "pair") - , ("sdec" , sdec) - , ("senc" , binaryId "senc") - , ("adec" , adec) - , ("aenc" , binaryId "aenc") - , ("sign" , binaryId "sign") - , ("checksign" , checksign) - , ("mac" , binaryId "mac") - ] -true :: Term -true = TBool True - -false :: Term -false = TBool False - -constId :: String -> TermFun -constId name [] = return $ TFun name [] 0 -constId name e = throwError $ NumArgs name 0 (map Term e) - -unaryId :: String -> TermFun -unaryId name [x] = return $ TFun name [x] 1 -unaryId name e = throwError $ NumArgs name 1 (map Term e) - -binaryId :: String -> TermFun -binaryId name [x,y] = return $ TFun name [x,y] 2 -binaryId name e = throwError $ NumArgs name 2 (map Term e) - -getmsg :: TermFun -getmsg [TFun "sign" [_,y] 2] = return y -getmsg e = throwError $ TypeMismatch "sign" $ map Term e - -first :: TermFun -first [TPair p] = return $ fst p -first e = throwError $ TypeMismatch "pair" $ map Term e - -secnd :: TermFun -secnd [TPair p] = return $ snd p -secnd e = throwError $ TypeMismatch "pair" $ map Term e - -sdec :: TermFun -sdec [k1, TFun "senc" [k2,y] 2] - |k1 == k2 = return y - |otherwise = throwError $ Default "keys not the same in sdec" -sdec e = throwError $ TypeMismatch "(var,senc(var,var))" $ map Term e - -adec :: TermFun -adec [x , TFun "aenc" [TFun "pk" [k] 1, y ] 2] - | x == k = return y - | otherwise= throwError $ Default "keys not same in adec" -adec e = throwError $ TypeMismatch "(var,aenc(pk(var),var))" $ map Term e - -checksign :: TermFun -checksign [TFun "pk" [k1] 1 , TFun "sign" [k2,_] 2 ] = return $ TBool (k1 == k2) -checksign e = throwError $ TypeMismatch "(pk(var),sign(var,var))" $ map Term e - -http :: TermFun -http [TStr url] = case httpGetRequest http' of - Just x -> return $ TStr x - Nothing -> throwError $ Default "malformed uri" - where - http' = if take 7 url /= http'' then http'' ++ url else url - http'' = "http://" -http _ = throwError $ Default "undefined" - main :: IO () main = do name <- getProgName @@ -423,45 +85,79 @@ [] -> runRepl coreBindings [x] -> readFile x >>= runProcess coreBindings _ -> do - putStrLn "Use:" + putStrLn "Use:" putStrLn $ name ++ " -- Enter the REPL" putStrLn $ name ++ " [process] -- Run single process" - -readProgram :: String -> ThrowsError PiProcess -readProgram input = case parse parseProcess "pi-calculus" input of - Left err -> throwError $ Parser err - Right val -> return val +load :: String -> IOThrowsError [PiProcess] +load filename = do + f <- liftIO $ tryIOError (readFile filename) + case f of + Left _ -> throwE $ Default "File does not exist" + Right f' -> liftThrows . readProcesses $ f' + evalCond :: Env -> Condition -> IOThrowsError Bool evalCond env (t1 `Equals` t2) = liftM2 (==) (evalTerm env t1) (evalTerm env t2) evalTerm :: Env -> Term -> IOThrowsError Value -evalTerm env (TVar name) = getVar env name +evalTerm env (TVar name _) = getVar env name evalTerm _ (TNum num) = return $ Term $ TNum num evalTerm _ (TStr str) = return $ Term $ TStr str evalTerm _ (TBool b ) = return $ Term $ TBool b +evalTerm _ (TData d ) = return $ Term $ TData d +evalTerm env (TList ls) = do + vs <- mapM (evalTerm env) ls + ts <- extractTerms vs + return $ Term $ TList ts evalTerm env (TPair (t1,t2)) = do a <- evalTerm env t1 b <- evalTerm env t2 case (a,b) of (Term c, Term d) -> return $ Term $ TPair (c,d) _ -> throwE $ Default "pair not given two terms" -evalTerm env (TFun "anonChan" [] 0) = do - port <- assignFreePort env - liftM Chan $ liftIO $ newChan Internal ("localhost:"++ show port) port -evalTerm _ (TFun "anonChan" [TNum n] 1) = liftM Chan $ liftIO $ newChan Internal ("localhost:"++ show n) n -evalTerm env (TFun "httpChan" [TStr addr] 1) = do - port <- assignFreePort env - liftM Chan $ liftIO $ newChan HTTP (addr ++ ":80") port -evalTerm env (TFun "chan" [TStr addr,TNum p] 2) = do +evalTerm env (TFun "anonChan" []) = do port <- assignFreePort env - liftM Chan $ liftIO $ newChan String (addr ++ ":" ++ show p) port -evalTerm env (TFun name args _) = do + liftM Chan $ liftIO $ newChan Init "localhost" port +evalTerm env (TFun "anonChan" [n]) = do + port <- evalToInt env n + c <- liftIO $ newChan Init "localhost" port + return $ Chan c +evalTerm env (TFun "httpChan" [a]) = do + host <- evalToString env a + liftM Chan $ liftIO $ newChan Connect host 80 +evalTerm env (TFun "chan" [a,n]) = do + host <- evalToString env a + port <- evalToInt env n + liftM Chan $ liftIO $ newChan Connect host port +evalTerm env (TFun name args) = do fun <- getVar env name argVals <- mapM (evalTerm env) args apply fun argVals +evalToString :: Env -> Term -> IOThrowsError String +evalToString env t = do + s <- evalTerm env t + str <- extractTerm s + extractString str +extractString :: Term -> IOThrowsError String +extractString str = + case str of + TStr s -> return s + _ -> throwE $ Default $ "Not a string : " ++ show str + +evalToInt :: Env -> Term -> IOThrowsError Integer +evalToInt env t = do + n <- evalTerm env t + num <- extractTerm n + extractInt num + +extractInt :: Term -> IOThrowsError Integer +extractInt num = + case num of + TNum n -> return n + _ -> throwE $ Default $ "Not a number : " ++ show num + assignFreePort :: Env -> IOThrowsError Integer assignFreePort env = do Term (TNum port) <- getVar env counterRef @@ -470,10 +166,9 @@ then error "HOW MANY CHANNELS DO YOU WANT?!" else return port - apply :: Value -> [Value] -> IOThrowsError Value apply (PrimitiveFunc fun) args = do - ts <- extracTerms args + ts <- extractTerms args res <- liftThrows $ fun ts return $ Term res apply (Func parms bdy closre) args = @@ -489,14 +184,12 @@ num = toInteger . length apply e _ = throwE $ NotFunction "expecting a function found" $ show e -extracTerms :: [Value] -> IOThrowsError [Term] -extracTerms ts - | all isTerm ts = return $ map (\(Term t) -> t) ts - | otherwise = throwE $ Default "not all terms" - -isTerm :: Value -> Bool -isTerm (Term _) = True -isTerm _ = False +extractTerms :: [Value] -> IOThrowsError [Term] +extractTerms = mapM extractTerm + +extractTerm :: Value -> IOThrowsError Term +extractTerm (Term t) = return t +extractTerm e = throwE $ Default $ "Trying to extract term from: " ++ show e liftThrows :: ThrowsError a -> IOThrowsError a liftThrows = either throwE return @@ -507,19 +200,29 @@ eval :: Env -> PiProcess -> IOThrowsError () eval _ Null = return () -eval env (In a (TVar name)) = do +eval env (In a v@(TVar b t)) = do chan <- evalChan env a - received <- receiveIn chan - _ <- defineVar env name received + term <- receiveIn chan t + bindings <- case term of + TFun "" ex -> do + ch <- decodeChannel ex + return [(b,ch)] + _ -> liftThrows $ match v term + mapM_ (uncurry (defineVar env)) bindings return () + where + decodeChannel e = do + extraStrings <- mapM extractString e + case getChannelData extraStrings of + Just (h,p) -> liftM Chan $ liftIO $ newChan Connect h p + Nothing -> throwE $ Default "incomplete data in channel" eval env (Out a b) = do chan <- evalChan env a bVal <- evalTerm env b sendOut chan bVal return () -eval env (Replicate proc) = liftIO (threadDelay 1000000) >> eval env (Conc [proc, Replicate proc]) +eval env (Replicate proc) = liftIO (threadDelay 100000) >> eval env (Conc [proc, Replicate proc]) eval env (Conc []) = eval env Null -eval env (Conc [proc]) = eval env proc eval env (Conc procs) = do var <- liftIO newEmptyMVar mapM_ (forkProcess var) procs @@ -535,30 +238,58 @@ eval env (p1 `Seq` p2) = do eval env p1 eval env p2 -eval env (New var@(TVar name)) = do - _ <- defineVar env name $ Term var - return () +eval env (New var@(TVar name _)) = void $ defineVar env name $ Term var eval env (If b p1 p2) = do cond <- evalCond env b eval env (if cond then p1 else p2) -eval env (Let (TVar name) (Term t2) (Just p)) = do +eval env (Let (TVar name _) (Term t2) (Just p)) = do val <- evalTerm env t2 newEnv <- liftIO $ bindVars env [(name,val)] eval newEnv p -eval env (Let (TVar name) (Term t2) Nothing) = do +eval env (Let (TVar name _) (Term t2) Nothing) = do val <- evalTerm env t2 _ <- defineVar env name val return () -eval env (Let (TFun name args _) t2 (Just p)) = +eval env (Let (TVar name _) proc@(Proc _) (Just p)) = do + newEnv <- liftIO $ bindVars env [(name,proc)] + eval newEnv p +eval env (Let (TVar name _) proc@(Proc _) Nothing) = do + _ <- defineVar env name proc + return () +eval env (Let (TFun name args) t2 (Just p)) = defineLocalFun env name args t2 p -eval env (Let (TFun name args _) t2 Nothing) = +eval env (Let (TFun name args) t2 Nothing) = defineGlobalFun env name args t2 +eval env (Let t1 (Term t2) (Just p)) = do + val <- evalTerm env t2 + case val of + Term term -> do + bindings <- liftThrows $ match t1 term + newEnv <- liftIO $ bindVars env bindings + eval newEnv p + _ -> throwE $ Default "Can only pattern match against Terms" +eval env (Let t1 (Term t2) Nothing) = do + val <- evalTerm env t2 + case val of + Term term -> do + bindings <- liftThrows $ match t1 term + mapM_ (uncurry (defineVar env)) bindings + _ -> throwE $ Default "Can only pattern match against Terms" +eval env (Atom (TFun "load" [TStr file])) = do + procs <- load file + eval env $ foldl Seq Null procs +eval env (Atom (TVar "env" Nothing)) = do + e <- liftIO $ readIORef env + liftIO $ mapM_ (\(k,v) -> putStrLn $ k ++ ": " ++ show v) $ Map.toAscList e +eval env (Atom p@(TFun{})) = void $ evalProcess env p +eval env (Atom p) = do + proc <- evalProcess env p + eval env proc eval _ _ = throwE $ Default "undefined action" defineGlobalFun :: Env -> String -> [Term] -> Value -> IOThrowsError () -defineGlobalFun env name args term = do - _ <- defineVar env name $ makeFun args term env - return () +defineGlobalFun env name args term = void $ defineVar env name $ makeFun args term env + defineLocalFun :: Env -> String -> [Term] -> Value -> PiProcess -> IOThrowsError () defineLocalFun env name args term p = do clos <- liftIO $ bindVars env [(name, makeFun args term env)] @@ -568,7 +299,7 @@ makeFun args = Func (map show args) evalString :: Env -> String -> IO String -evalString env expr = runIOThrows $ liftM show $ liftThrows (readProgram expr) >>= eval env +evalString env expr = runIOThrows $ liftM show $ liftThrows (readProcess expr) >>= eval env runIOThrows :: IOThrowsError String -> IO String runIOThrows action = liftM extractValue $ runExceptT (trapError action) @@ -576,11 +307,6 @@ trapError :: IOThrowsError String -> IOThrowsError String trapError action = catchE action (return . show) -readTerm :: String -> ThrowsError Term -readTerm str = case parse parseTerm "Term" str of - Left err -> throwError $ Parser err - Right val -> return val - evalAndPrint :: Env -> String -> IO () evalAndPrint env expr = do res <- evalString env expr @@ -608,31 +334,45 @@ flushStr str = putStr str >> hFlush stdout sendOut :: Channel -> Value -> IOThrowsError () +sendOut chan v@(Chan c) = if serialisable c + then liftIO $ send chan $ show v + else throwE $ Default "Channel not serialisable" sendOut chan val = liftIO $ send chan $ show val -receiveIn :: Channel -> IOThrowsError Value -receiveIn chan = do - msg <- liftIO $ receive chan - let term = extractValue $ readTerm msg - case term of - TFun "" ex _ -> decodeChannel ex - _ -> return $ Term term - where - decodeChannel e = do - let extraStrings = map (\(TStr x) -> x) e - let extraData = map (second tail . break (==dataBreak)) extraStrings - case getChannelData extraData of - Just (t,h,p) -> liftM Chan $ liftIO $ newChan t h p - Nothing -> throwE $ Default "incomplete data in channel" - -getChannelData :: [(String,String)] -> Maybe (ChannelType, String, Integer) -getChannelData ex = do - t <- lookup "type" ex - host <- lookup "host" ex - cp <- lookup "clientPort" ex - return (read t,host,read cp) +receiveIn :: Channel -> Maybe Type -> IOThrowsError Term +receiveIn chan t = do + str <- liftIO $ receive chan + case t of + Just HttpRequest -> makeHttpRequest str + Just HttpResponse -> makeHttpResponse str + _ -> liftThrows $ readTerm str +makeHttpRequest :: String -> IOThrowsError Term +makeHttpRequest str = do + let ls = lines str + (r,u, hs) <- case parseRequestHead ls of + Left _ -> throwE $ Default "Malformed HTTP Request" + Right (r,u,h) -> return (r,u,h) + return $ TData $ Req $ Request u r hs (msgBody ls) + +makeHttpResponse :: String -> IOThrowsError Term +makeHttpResponse str = do + let ls = lines str + (c, r, hs) <- case parseResponseHead ls of + Left _ -> throwE $ Default "Malformed HTTP Request" + Right (c,r,h) -> return (c,r,h) + return $ TData $ Resp $ Response c r hs (msgBody ls) + +msgBody :: [String] -> String +msgBody = unlines . dropWhile (/= crlf) + where + crlf = "\r" + +todo :: IOThrowsError a +todo = throwE $ Default "TODO" + + evalChan :: Env -> Term -> IOThrowsError Channel evalChan env t = do chan <- evalTerm env t @@ -640,9 +380,9 @@ Chan c -> return c _ -> throwE $ NotChannel $ show t - -httpGetRequest :: String -> Maybe String -httpGetRequest str = do - uri <- parseURI str - return $ show (mkRequest GET uri :: Request String) - +evalProcess :: Env -> Term -> IOThrowsError PiProcess +evalProcess env t = do + proc <- evalTerm env t + case proc of + Proc p -> return p + _ -> throwE $ NotProcess $ show t diff --git a/Primitives.hs b/Primitives.hs new file mode 100644 --- /dev/null +++ b/Primitives.hs @@ -0,0 +1,206 @@ +module Primitives (primitives) where + +import Control.Applicative ((<$>)) +import Control.Monad.Error (throwError) +import Network.HTTP.Base (Request(..), Response(..), RequestMethod(..), mkRequest) +import Network.HTTP.Cookie (Cookie, cookiesToHeader) +import Network.HTTP.Headers (HasHeaders(..), Header, HeaderName(..), hdrName, hdrValue, findHeader, parseHeader, replaceHeader, setHeaders) +import Network.URI (parseURI) + +import TypDefs + +primitives :: [(String , TermFun)] +primitives = [ ("fst" , first) + , ("snd" , secnd) + , ("hash" , unaryId "hash") + , ("pk" , unaryId "pk") + , ("httpReq" , httpReq) + , ("httpResp" , httpResp) + , ("getmsg" , getmsg) + , ("pair" , binaryId "pair") + , ("sdec" , sdec) + , ("senc" , binaryId "senc") + , ("adec" , adec) + , ("aenc" , binaryId "aenc") + , ("sign" , binaryId "sign") + , ("checksign" , checksign) + , ("mac" , binaryId "mac") + , ("headers" , listId) + , ("header" , header) + , ("cookies" , listId) + , ("httpGet" , constId "httpGet") + , ("httpHead" , constId "httpHead") + , ("httpPost" , constId "httpPost") + , ("getHeaders", getHeadersFromData) + , ("setHeader" , setHeader) + , ("getHeader" , getHeader) + , ("getCookie" , getCookie) + , ("setCookie" , setCookie) + , ("uri" , makeUri) + , ("rspCode" , responseCode) + , ("add" , add) + , ("cons" , cons) + , ("head" , head') + , ("tail" , tail') + ] + +constId :: String -> TermFun +constId name [] = return $ TFun name [] +constId name e = throwError $ NumArgs name 0 (map Term e) + +unaryId :: String -> TermFun +unaryId name [x] = return $ TFun name [x] +unaryId name e = throwError $ NumArgs name 1 (map Term e) + +binaryId :: String -> TermFun +binaryId name [x,y] = return $ TFun name [x,y] +binaryId name e = throwError $ NumArgs name 2 (map Term e) + +listId :: TermFun +listId ts = return $ TList ts + +getmsg :: TermFun +getmsg [TFun "sign" [_,y]] = return y +getmsg e = throwError $ TypeMismatch "sign" $ map Term e + +first :: TermFun +first [TPair p] = return $ fst p +first e = throwError $ TypeMismatch "pair" $ map Term e + +secnd :: TermFun +secnd [TPair p] = return $ snd p +secnd e = throwError $ TypeMismatch "pair" $ map Term e + +sdec :: TermFun +sdec [k1, TFun "senc" [k2,y]] + |k1 == k2 = return y + |otherwise = throwError $ Default "keys not the same in sdec" +sdec e = throwError $ TypeMismatch "(var,senc(var,var))" $ map Term e + +adec :: TermFun +adec [x , TFun "aenc" [TFun "pk" [k], y ]] + | x == k = return y + | otherwise= throwError $ Default "keys not same in adec" +adec e = throwError $ TypeMismatch "(var,aenc(pk(var),var))" $ map Term e + +checksign :: TermFun +checksign [TFun "pk" [k1], TFun "sign" [k2,_] ] = return $ TBool (k1 == k2) +checksign e = throwError $ TypeMismatch "(pk(var),sign(var,var))" $ map Term e + +httpReq :: TermFun +httpReq [TStr url, TList hs , reqMethod] = do + uri <- case parseURI http' of + Just x -> return x + Nothing -> throwError $ Default "Malformed uri" + hss <- makeHeaders hs + let req = mkRequest method uri :: Request String in + return $ TData $ Req $ setHeaders req hss + where + http' = if take 7 url /= http'' then http'' ++ url else url + http'' = "http://" + method + | reqMethod == constFun "httpGet" = GET + | reqMethod == constFun "httpHead" = HEAD + | reqMethod == constFun "httpPost" = POST + | otherwise = GET + where constFun x = TFun x [] +httpReq e = throwError $ TypeMismatch "(url,headers,method)" $ map Term e + +httpResp :: TermFun +httpResp [TNum code, TStr reason , TList hs ,TStr bdy] = do + headers <- makeHeaders hs + return $ TData $ Resp $ Response (parseCode code) reason headers bdy + where parseCode c = case digits c of + [x,y,z] -> (x,y,z) + _ -> (-1,-1,-1) +httpResp e = throwError $ TypeMismatch "(code,reason,headers,body)" $ map Term e + +makeHeaders :: [Term] -> ThrowsError [Header] +makeHeaders = mapM makeHeader + +makeHeader :: Term -> ThrowsError Header +makeHeader (TFun "cookies" cs) = do + cookies <- mapM makeCookie cs + return $ cookiesToHeader cookies +makeHeader (TStr s) = case parseHeader s of + Left _ -> throwError $ Default "malformed header" + Right h -> return h +makeHeader _ = throwError $ Default "not a header" + +header :: TermFun +header [TStr n , TStr v] = TStr . show <$> makeHeader (TStr (n ++ ":" ++ v)) +header e = throwError $ TypeMismatch "(headerName, headerValue)" $ map Term e + +makeCookie :: Term -> ThrowsError Cookie +makeCookie (TStr c) = return $ read c +makeCookie _ = throwError $ Default "malformed cookie" + +getHeadersFromData :: TermFun +getHeadersFromData [TData d] = return $ TList $ map (TStr . show) $ getHeaders d +getHeadersFromData e = throwError $ TypeMismatch "httpData" $ map Term e + +getHeader :: TermFun +getHeader [TStr headr, TData d] = do + h <- case parseHeader $ headr ++ ":" of + Right h -> return h + _ -> throwError $ Default $ "Not a header: " ++ headr + case findHeader (hdrName h) d of + Just hr -> return $ TStr hr + _ -> throwError $ Default $ headr ++ " not in " ++ show d +getHeader e = throwError $ TypeMismatch "httpData" $ map Term e + +setHeader :: TermFun +setHeader [h@(TStr _), TData d] = do + headr <- makeHeader h + let name = hdrName headr + let val = hdrValue headr + return $ TData $ replaceHeader name val d +setHeader [h@(TStr _), TList hs] = return $ TList $ h : hs +setHeader e = throwError $ TypeMismatch "(header,httpData|headers)" $ map Term e + +getCookie :: TermFun +getCookie [TData d] = + case findHeader HdrCookie d of + Just x -> return $ TStr x + Nothing -> throwError $ Default "cookie not found" +getCookie e = throwError $ TypeMismatch "httpData" $ map Term e + +setCookie :: TermFun +setCookie [TData d, c] = do + cookie <- makeCookie c + let cookieHeader = cookiesToHeader [cookie] + let n = hdrName cookieHeader + let s = hdrValue cookieHeader + return $ TData $ replaceHeader n s d +setCookie e = throwError $ TypeMismatch "(httpData, cookie)" $ map Term e + +makeUri :: TermFun +makeUri [TStr host,TStr path] = return $ TStr $ host ++ "/" ++ path +makeUri e = throwError $ TypeMismatch "(string,string)" $ map Term e + +responseCode :: TermFun +responseCode [TData d] = case d of + Req _ -> throwError $ Default "Trying to extract Response Code from HttpRequest" + Resp r -> return $ TNum $ let (x,y,z) = rspCode r in fromIntegral (100 * x + 10 * y + z) +responseCode e = throwError $ TypeMismatch "(string,string)" $ map Term e + +digits :: Integer -> [Int] +digits n = map (read . return) $ show n + +add :: TermFun +add [TNum a, TNum b] = return $ TNum $ a + b +add e = throwError $ TypeMismatch "(num,num)" $ map Term e + +cons :: TermFun +cons [a, TList x] = return $ TList (a:x) +cons e = throwError $ TypeMismatch "list" $ map Term e + +head' :: TermFun +head' [TList []] = throwError $ Default "head of empty list" +head' [TList xs] = return $ head xs +head' e = throwError $ TypeMismatch "list" $ map Term e + +tail' :: TermFun +tail' [TList []] = throwError $ Default "tail of empty list" +tail' [TList x] = return $ TList $ tail x +tail' e = throwError $ TypeMismatch "list" $ map Term e diff --git a/TypDefs.hs b/TypDefs.hs new file mode 100644 --- /dev/null +++ b/TypDefs.hs @@ -0,0 +1,180 @@ +module TypDefs ( + PiProcess (..), + Term (..), + TermFun , + HttpData (..), + Condition (..), + Value (..), + Type (..), + Channel (..), + BuildType (..), + PiError (..), + IOThrowsError , + ThrowsError , + Name , + Env ) + where + +import Control.Monad.Trans.Except(ExceptT(..)) +import Data.Char (toLower) +import Data.IORef (IORef) +import Data.List (intercalate) +import Data.Map (Map) +import Network.HTTP.Base (Request, Response) +import Network.HTTP.Headers (HasHeaders(..)) + +import Text.ParserCombinators.Parsec (ParseError) + +data PiProcess = Null + | In Term Term + | Out Term Term + | New Term + | PiProcess `Seq` PiProcess + | Conc [PiProcess] + | Replicate PiProcess + | Let Term Value (Maybe PiProcess) + | If Condition PiProcess PiProcess + | Atom Term + deriving (Eq) + +data Term = TVar Name (Maybe Type) + | TStr String + | TNum Integer + | TBool Bool + | TPair (Term, Term) + | TList [Term] + | TData HttpData + | TFun Name [Term] + deriving (Eq) + +data HttpData = Resp (Response String) + | Req (Request String) + +instance Eq HttpData where (==) = eqHttpData +instance Show HttpData where show = showHttpData + +instance HasHeaders HttpData where + getHeaders (Resp r) = getHeaders r + getHeaders (Req r) = getHeaders r + setHeaders (Resp r) = Resp . setHeaders r + setHeaders (Req r) = Req . setHeaders r + +showHttpData :: HttpData -> String +showHttpData (Resp r) = show r +showHttpData (Req r) = show r + +eqHttpData :: HttpData -> HttpData -> Bool +eqHttpData _ _ = False + +type TermFun = [Term] -> ThrowsError Term + +type Name = String +data Condition = Term `Equals` Term deriving (Eq) + +data Value = Proc PiProcess + | Term Term + | Chan Channel + | PrimitiveFunc TermFun + | Func {params :: [String] , body :: Value, closure :: Env} + +type IOThrowsError = ExceptT PiError IO +type ThrowsError = Either PiError + +data PiError = NumArgs Name Integer [Value] + | TypeMismatch String [Value] + | Parser ParseError + | UnboundVar String String + | NotTerm Name Value + | NotFunction String String + | NotChannel String + | NotProcess String + | PatternMatch Term Term + | Default String + +data Type = HttpRequest + | HttpResponse + | Header + | List Type + deriving (Eq, Read, Show) + +instance Show PiError where show = showError + +showError :: PiError -> String +showError (UnboundVar message var) = message ++ ": " ++ var +showError (NotFunction message fun) = message ++ ": " ++ fun +showError (NotChannel chan) = "Not a channel: " ++ chan +showError (NotProcess proc) = "Not a Process: " ++ proc +showError (NotTerm name var) = "Expecting " ++ name ++ " to be a Term, found: " ++ show var +showError (NumArgs name expected found) = "Expected " ++ show name ++ show expected ++ " args; found values " + ++ unwordsList found +showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " + ++ show found +showError (Parser parseErr) = "Parse error at " ++ show parseErr +showError (PatternMatch t1 t2) = "Pattern match failure: cannot match " ++ show t1 ++ " and \n" ++ show t2 +showError (Default msg) = msg + +type Env = IORef (Map String Value) + +data Channel = Channel { + send :: String -> IO () + , receive :: IO String + , extra :: [String] + } + +data BuildType = Init + | Connect + deriving (Eq, Show, Read) + +showValue :: Value -> String +showValue (Proc p) = show p +showValue (Term t) = show t +showValue (Chan c) = show $ convert c + where + convert ch = TFun "" (map TStr ex) + where ex = extra ch +showValue (PrimitiveFunc _) = "" +showValue (Func {}) = "" + +eqvVal :: Value -> Value -> Bool +eqvVal (Proc p1) (Proc p2) = p1 == p2 +eqvVal (Term t1) (Term t2) = t1 == t2 +eqvVal _ _ = False + +instance Eq Value where (==) = eqvVal + +showPi :: PiProcess -> String +showPi Null = "0" +showPi (In c m) = "in(" ++ show c ++ "," ++ show m ++ ")" +showPi (Out c m) = "out(" ++ show c ++ "," ++ show m ++ ")" +showPi (Replicate proc) = "!(" ++ show proc ++ ")" +showPi (Conc procs) = intercalate "|" $ map show procs +showPi (p1 `Seq` Null) = show p1 +showPi (p1 `Seq` p2) = show p1 ++ ";" ++ show p2 +showPi (New n) = "new " ++ show n +showPi (If c p1 Null) = "if " ++ show c ++ " then " ++ show p1 +showPi (If c p1 p2) = "if " ++ show c ++ " then " ++ show p1 ++ " else " ++ show p2 +showPi (Let n t p) = "let " ++ show n ++ " = " ++ show t ++ case p of {Nothing -> "" ; Just x -> " in\n" ++ show x} +showPi (Atom t) = show t + +showTerm :: Term -> String +showTerm (TVar x t) = x ++ (case t of + Nothing -> "" + Just ty -> ": " ++ show ty) +showTerm (TStr str) = str +showTerm (TNum num) = show num +showTerm (TBool b ) = map toLower $ show b +showTerm (TList ls) = "list(" ++ intercalate "," (map show ls) ++ ")" +showTerm (TPair (a,b)) = "pair("++ show a ++ ","++ show b ++ ")" +showTerm (TData d) = show d +showTerm (TFun n ts) = n ++ "(" ++ intercalate "," (map show ts) ++ ")" + +showCond :: Condition -> String +showCond (t1 `Equals` t2) = show t1 ++ " == " ++ show t2 + +instance Show PiProcess where show = showPi +instance Show Term where show = showTerm +instance Show Condition where show = showCond +instance Show Value where show = showValue + +unwordsList :: [Value] -> String +unwordsList = unwords . map show diff --git a/pi-calculus.cabal b/pi-calculus.cabal --- a/pi-calculus.cabal +++ b/pi-calculus.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: pi-calculus -version: 0.0.1 +version: 0.0.3 synopsis: Applied pi-calculus compiler description: Phi - A compiler for the applied pi-calculus. Very rough around the edges. license: GPL-3 @@ -10,11 +10,12 @@ author: Will de Renzy-Martin maintainer: will.derenzymartin@gmail.com -- copyright: +homepage: https://github.com/renzyq19/pi-calculus category: Web build-type: Simple cabal-version: >=1.8 executable phi main-is: PiCalculus.hs - other-modules: Channel - build-depends: base >=4.5 && <=4.7, mtl ==2.2.*, parsec ==3.1.*, containers ==0.5.*, transformers ==0.4.*, network ==2.5.*, HTTP >=2.15 + other-modules: Channel, Parser, PatternMatching, Primitives, TypDefs + build-depends: base >=4.5 && <=4.8, mtl ==2.2.*, parsec ==3.1.*, containers ==0.5.*, transformers ==0.4.*, network ==2.5.*, HTTP >=2.15, bytestring >= 0.10, io-streams ==1.1.*