pi-calculus 0.0.1 → 0.0.3
raw patch · 7 files changed
+910/−503 lines, 7 filesdep +bytestringdep +io-streamsdep ~base
Dependencies added: bytestring, io-streams
Dependency ranges changed: base
Files
- Channel.hs +84/−73
- Parser.hs +227/−0
- PatternMatching.hs +42/−0
- PiCalculus.hs +167/−427
- Primitives.hs +206/−0
- TypDefs.hs +180/−0
- pi-calculus.cabal +4/−3
Channel.hs view
@@ -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)
+ Parser.hs view
@@ -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
+ PatternMatching.hs view
@@ -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-}+
PiCalculus.hs view
@@ -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 "<chan>" (map TStr ex) $ length ex- where ex = extra ch-showValue (PrimitiveFunc _) = "<primitive>" -showValue (Func {}) = "<user function>" --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 "<chan>" 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 "<chan>" 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
+ Primitives.hs view
@@ -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
+ TypDefs.hs view
@@ -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 "<chan>" (map TStr ex) + where ex = extra ch+showValue (PrimitiveFunc _) = "<primitive>" +showValue (Func {}) = "<user function>" ++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
pi-calculus.cabal view
@@ -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.*