diff --git a/PatternMatching.hs b/PatternMatching.hs --- a/PatternMatching.hs +++ b/PatternMatching.hs @@ -1,19 +1,26 @@ -module PatternMatching (match) where +module PatternMatching (match, matchTest) where import Control.Arrow (second) -import Control.Monad (liftM,liftM2,zipWithM) +import Control.Monad (liftM,liftM2) import Control.Monad.Error (throwError) import TypDefs -import Parser () +import Parser (readTerm) 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' (TVar name _) term = case name of + '_':_ -> return [] + _ -> 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' (TList (m:ms)) (TList (t:ts)) = do + bind <- match' m t + rest <- case ms of + [v] -> match' v $ TList ts + _ -> match' (TList ms) (TList ts) + return $ bind ++ rest match' l@(TList _) (TData d) = match' l $ dataToList d match' t1 t2 = throwError $ PatternMatch t1 t2 @@ -34,9 +41,9 @@ headers = map (TStr . show) $ rspHeaders r bdy = rspBody r -{-testMatch :: String -> String -> ThrowsError [(String,Term)] -testMatch s1 s2 = do +matchTest :: String -> String -> ThrowsError [(String,Value)] +matchTest s1 s2 = do t1 <- readTerm s1 t2 <- readTerm s2 - match' t1 t2-} + match t1 t2 diff --git a/PiCalculus.hs b/PiCalculus.hs --- a/PiCalculus.hs +++ b/PiCalculus.hs @@ -17,9 +17,10 @@ import Channel import Parser +import Paths_pi_calculus +import PatternMatching import Primitives import TypDefs -import PatternMatching nullEnv :: IO Env nullEnv = newIORef Map.empty @@ -79,11 +80,12 @@ main :: IO () main = do - name <- getProgName - args <- getArgs + name <- getProgName + args <- getArgs + pilude <- getDataFileName "pilude.pi" case args of [] -> runRepl coreBindings - [x] -> readFile x >>= runProcess coreBindings + [x] -> liftM (("&load("++pilude++");")++) (readFile x) >>= runProcess coreBindings _ -> do putStrLn "Use:" putStrLn $ name ++ " -- Enter the REPL" @@ -275,6 +277,9 @@ bindings <- liftThrows $ match t1 term mapM_ (uncurry (defineVar env)) bindings _ -> throwE $ Default "Can only pattern match against Terms" +eval env (Atom (TFun "load" [TStr "pilude.pi"])) = do + pilude <- liftIO $ getDataFileName "pilude.pi" + eval env (Atom (TFun "load" [TStr pilude])) eval env (Atom (TFun "load" [TStr file])) = do procs <- load file eval env $ foldl Seq Null procs diff --git a/TypDefs.hs b/TypDefs.hs --- a/TypDefs.hs +++ b/TypDefs.hs @@ -160,7 +160,7 @@ showTerm (TVar x t) = x ++ (case t of Nothing -> "" Just ty -> ": " ++ show ty) -showTerm (TStr str) = str +showTerm (TStr str) = show str showTerm (TNum num) = show num showTerm (TBool b ) = map toLower $ show b showTerm (TList ls) = "list(" ++ intercalate "," (map show ls) ++ ")" 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.3 +version: 0.0.4 synopsis: Applied pi-calculus compiler description: Phi - A compiler for the applied pi-calculus. Very rough around the edges. license: GPL-3 @@ -14,8 +14,9 @@ category: Web build-type: Simple cabal-version: >=1.8 +data-files: testing/*.pi, pilude.pi executable phi main-is: PiCalculus.hs - other-modules: Channel, Parser, PatternMatching, Primitives, TypDefs + other-modules: Channel, Parser, PatternMatching, Primitives, TypDefs, Paths_pi_calculus 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.* diff --git a/pilude.pi b/pilude.pi new file mode 100644 --- /dev/null +++ b/pilude.pi @@ -0,0 +1,5 @@ +let triple(a,b,c) = pair(a,pair(b,c)) +let print(msg) = out(stdout,msg) +let error(msg) = out(stderr,msg) +let dbgOut(c, msg) = out(c,msg);out(stdout,msg) +let forever(process) = &process;&forever(process) diff --git a/testing/client.pi b/testing/client.pi new file mode 100644 --- /dev/null +++ b/testing/client.pi @@ -0,0 +1,6 @@ +out(stdout,"Enter host:"); in(stdin,host); +out(stdout,"Enter port:"); in(stdin,port); +let ch = chan(host,port) in + let sch = {} in + out(stdout,sch);out(ch,sch);in(sch,msg);out(stdout,msg) + diff --git a/testing/follow.pi b/testing/follow.pi new file mode 100644 --- /dev/null +++ b/testing/follow.pi @@ -0,0 +1,5 @@ +let follow(ch,r) = (out(ch,r);in(ch,resp:HttpResponse); + let list(c,_,h,_) = resp in + if c = 302 + then let req = httpReq(getHeader("location",resp),headers(),httpGet()) in &follow(ch,req) + else out(stdout,h)) diff --git a/testing/hanshake.pi b/testing/hanshake.pi new file mode 100644 --- /dev/null +++ b/testing/hanshake.pi @@ -0,0 +1,5 @@ +new sks; new skc; new s; let pks = pk(sks) in let pkc = pk(skc) in (out(c,pks);0) | (out(c,pkc);0)|!(0)|!(0) + +in(c,xpk);new k ; out(c, aenc(xpk, sign(sks,k))); in(c,z); if fst(sdec(k, z)) == tag then 0 else 0 + +in(c,y);let y' = adec(skc,y) in let yk = getmsg(y') in if checksign(pks, y') == true then out(c, senc( yk , pair( tag, s))) ; 0 else 0 diff --git a/testing/index.pi b/testing/index.pi new file mode 100644 --- /dev/null +++ b/testing/index.pi @@ -0,0 +1,4 @@ +&load("follow.pi"); +out(stdout,"Host:");in(stdin,site); +let siteChan = httpChan(site) in +let req = httpReq(uri(site,"index.html"),headers(),httpGet()) in &follow(siteChan,req) diff --git a/testing/server.pi b/testing/server.pi new file mode 100644 --- /dev/null +++ b/testing/server.pi @@ -0,0 +1,3 @@ +out(stdout,"Enter port:"); in(stdin,port); +let ch = {port} in + in(ch,sch);out(stdout,sch);in(stdin,msg);out(sch,msg) diff --git a/testing/test.pi b/testing/test.pi new file mode 100644 --- /dev/null +++ b/testing/test.pi @@ -0,0 +1,4 @@ +let google = "www.google.com" in +let chan = httpChan(google) in +let req = httpReq(google, headers(), httpGet()) in +out(chan,req);in(chan,httpResp(_,_,_,body));out(stdout,body)