diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.2.16 +Version: 3.2.17 Synopsis: Programming language with non-linear pattern-matching against unfree data types Description: An interpreter for Egison, the programming langugage that realized non-linear pattern-matching against unfree data types. @@ -39,7 +39,7 @@ location: https://github.com/egisatoshi/egison3.git Library - Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, bytestring, text, regex-posix + Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, bytestring, text, regex-posix, direct-sqlite Hs-Source-Dirs: hs-src Exposed-Modules: Language.Egison diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -33,13 +33,9 @@ import Control.Monad -{-- -- for 'egison-sqlite' +-- {-- -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite ---} -- for 'egison-sqlite' - -{-- -- for 'egison-mysql' -import qualified Database.MySQL.Base as MySQL ---} -- for 'egison-mysql' +-- --} -- for 'egison-sqlite' import Language.Egison.Types import Language.Egison.Parser @@ -165,14 +161,6 @@ , ("assert", assert) , ("assert-equal", assertEqual) - -{-- -- for 'egison-sqlite' - , ("pure-sqlite", pureSQLite) ---} -- for 'egison-sqlite' - -{-- -- for 'egison-mysql' - , ("pure-mysql", pureMySQL) ---} -- for 'egison-mysql' ] integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc @@ -402,13 +390,18 @@ uncons' :: PrimitiveFunc uncons' whnf = do - (carObjRef, cdrObjRef) <- fromJust <$> runMaybeT (unconsCollection whnf) - return $ Intermediate $ ITuple [carObjRef, cdrObjRef] + mRet <- runMaybeT (unconsCollection whnf) + case mRet of + Just (carObjRef, cdrObjRef) -> return $ Intermediate $ ITuple [carObjRef, cdrObjRef] + Nothing -> throwError $ Default $ "cannot uncons collection" + unsnoc' :: PrimitiveFunc unsnoc' whnf = do - (racObjRef, rdcObjRef) <- fromJust <$> runMaybeT (unsnocCollection whnf) - return $ Intermediate $ ITuple [racObjRef, rdcObjRef] + mRet <- runMaybeT (unsnocCollection whnf) + case mRet of + Just (racObjRef, rdcObjRef) -> return $ Intermediate $ ITuple [racObjRef, rdcObjRef] + Nothing -> throwError $ Default $ "cannot unsnoc collection" assert :: PrimitiveFunc assert = twoArgs $ \label test -> do @@ -423,55 +416,7 @@ then return $ Bool True else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual -{-- -- for 'egison-sqlite' -pureSQLite :: PrimitiveFunc -pureSQLite = (liftError .) $ twoArgs $ \val val' -> do - dbName <- fromStringValue val - qStr <- fromStringValue val' - let ret = unsafePerformIO $ query' (T.pack dbName) $ T.pack qStr - return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeEgisonString r)) ret - where - query' :: T.Text -> T.Text -> IO [[String]] - query' dbName q = do - db <- SQLite.open dbName - rowsRef <- newIORef [] - SQLite.execWithCallback db q (\_ _ mcs -> do - row <- forM mcs (\mcol -> case mcol of - Just col -> return $ T.unpack col - Nothing -> return "null") - rows <- readIORef rowsRef - writeIORef rowsRef (row:rows)) - SQLite.close db - ret <- readIORef rowsRef - return $ reverse ret ---} -- for 'egison-sqlite' -{-- -- for 'egison-mysql' -pureMySQL :: PrimitiveFunc -pureMySQL = (liftError .) $ twoArgs $ \val val' -> do - dbName <- fromStringValue val - qStr <- fromStringValue val' - let ret = unsafePerformIO $ query' dbName $ BC.pack qStr - return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeEgisonString r)) ret - where - query' :: String -> ByteString -> IO [[String]] - query' dbName q = do - conn <- MySQL.connect MySQL.defaultConnectInfo { MySQL.connectDatabase = dbName } - MySQL.query conn q - ret <- MySQL.storeResult conn - fetchAllRows ret - fetchAllRows :: MySQL.Result -> IO [[String]] - fetchAllRows ret = do - row <- MySQL.fetchRow ret - case row of - [] -> return [] - _ -> do row' <- forM row (\mcol -> case mcol of - Just col -> return $ BC.unpack col - Nothing -> return "null") - rows' <- fetchAllRows ret - return $ row':rows' ---} -- for 'egison-mysql' - -- -- IO Primitives -- @@ -591,3 +536,27 @@ i' <- fromEgison val' n <- liftIO $ getStdRandom $ randomR (i, i') return $ makeIO $ return (Integer n) + +-- {-- -- for 'egison-sqlite' +sqlite :: PrimitiveFunc +sqlite = twoArgs $ \val val' -> do + dbName <- fromEgison val + qStr <- fromEgison val' + ret <- liftIO $ query' (T.pack dbName) $ T.pack qStr + return $ Collection $ Sq.fromList $ map (\r -> Tuple (map toEgison r)) ret + where + query' :: T.Text -> T.Text -> IO [[String]] + query' dbName q = do + db <- SQLite.open dbName + rowsRef <- newIORef [] + SQLite.execWithCallback db q (\_ _ mcs -> do + row <- forM mcs (\mcol -> case mcol of + Just col -> return $ T.unpack col + Nothing -> return "null") + rows <- readIORef rowsRef + writeIORef rowsRef (row:rows)) + SQLite.close db + ret <- readIORef rowsRef + return $ reverse ret +-- --} -- for 'egison-sqlite' + diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -174,7 +174,6 @@ data EgisonPattern = WildCard | PatVar String - | VarPat String | ValuePat EgisonExpr | PredPat EgisonExpr | IndexedPat EgisonPattern [EgisonExpr] @@ -184,9 +183,10 @@ | OrPat [EgisonPattern] | TuplePat [EgisonPattern] | InductivePat String [EgisonPattern] - | ApplyPat EgisonExpr [EgisonPattern] | LoopPat String LoopRange EgisonPattern EgisonPattern | ContPat + | ApplyPat EgisonExpr [EgisonPattern] + | VarPat String deriving (Show) data LoopRange = diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -2,9 +2,7 @@ ;; Base.egi ;; -(define $id (lambda [$x] x)) - -(define $bool +(define $buildin-data-matcher (matcher {[,$val [] {[$tgt (if (eq? val tgt) @@ -13,7 +11,11 @@ [$ [something] {[$tgt {tgt}]}] })) + +(define $id (lambda [$x] x)) +(define $bool buildin-data-matcher) + (define $or (lambda [$b1 $b2] (if b1 @@ -32,15 +34,7 @@ {[,#t #f] [,#f #t]}))) -(define $char - (matcher - {[,$c [] - {[$tgt (if (eq? tgt c) - {[]} - {})]}] - [$ [something] - {[$tgt {tgt}]}] - })) +(define $char buildin-data-matcher) (define $eq?/m (lambda [$a $x $y] diff --git a/lib/core/database.egi b/lib/core/database.egi --- a/lib/core/database.egi +++ b/lib/core/database.egi @@ -33,3 +33,8 @@ (match (loop-fn wheres) (list string) {[ ""] [ {@"where " @(intercalate " and " {wc @wcs})}]})))) + +;; +;; for SQLite +;; +(define $pure-sqlite (lambda [$q] (io (sqlite q)))) diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -7,23 +7,7 @@ ;;; ;;; Integers ;;; -(define $integer - (matcher - {[,$n [] - {[$tgt (if (eq? tgt n) - {[]} - {})]}] - [$ [something] - {[$tgt {tgt}]}] - })) - -(define $compare-integer - (lambda [$m $n] - (if (lt? m n) - - (if (eq? m n) - - )))) +(define $integer buildin-data-matcher) (define $min (lambda [$ns] @@ -75,18 +59,4 @@ ;; ;; Float Numbers ;; -(define $float - (matcher - {[,$d [] - {[$tgt (if (eq? tgt d) {[]} {})]}] - [$ [something] - {[$tgt {tgt}]}] - })) - -(define $compare-float - (lambda [$d1 $d2] - (if (lt? d1 d2) - - (if (eq? d1 d2) - - )))) +(define $float buildin-data-matcher) diff --git a/lib/core/order.egi b/lib/core/order.egi --- a/lib/core/order.egi +++ b/lib/core/order.egi @@ -8,24 +8,32 @@ (algebraic-data-matcher { })) +(define $compare + (lambda [$m $n] + (if (lt? m n) + + (if (eq? m n) + + )))) + (define $split-by-ordering - (lambda [$compare] + (lambda [$compare-fn] (lambda [$xs $p] (match xs (list something) {[ [{} {} {}]] [ - (let {[[$ys1 $ys2 $ys3] ((split-by-ordering compare) rs p)]} - (match (compare x p) ordering + (let {[[$ys1 $ys2 $ys3] ((split-by-ordering compare-fn) rs p)]} + (match (compare-fn x p) ordering {[ [{x @ys1} ys2 ys3]] [ [ys1 {x @ys2} ys3]] [ [ys1 ys2 {x @ys3}]]}))]})))) (define $qsort - (lambda [$compare] + (lambda [$compare-fn] (match-lambda (list something) {[ {}] [> {x}] [$xs (let {[$n (length xs)]} (let {[$p (nth (quotient n 2) xs)]} - (let {[[$ys1 $ys2 $ys3] ((split-by-ordering compare) xs p)]} - {@((qsort compare) ys1) @ys2 @((qsort compare) ys3)})))]}))) + (let {[[$ys1 $ys2 $ys3] ((split-by-ordering compare-fn) xs p)]} + {@((qsort compare-fn) ys1) @ys2 @((qsort compare-fn) ys3)})))]}))) diff --git a/sample/social-graph.egi b/sample/social-graph.egi deleted file mode 100644 --- a/sample/social-graph.egi +++ /dev/null @@ -1,81 +0,0 @@ -;;; -;;; -;;; Social-graph Demonstration -;;; -;;; - -;; -;; Matcher definition -;; -(define $user - (matcher - {[,$u [] - {[$tgt (match [u tgt] [user user] - {[[ ] {[]}] - [_ {}]})]}] - [ [integer] - {[ {id}]}] - [ [string] - {[ {name}]}] - [ [string] - {[ {txt}]}] - [$ [something] - {[$tgt {tgt}]}] - })) - -(define $user-table (multiset user)) - -(define $follow - (matcher - {[,$f [] - {[$tgt (match [f tgt] [follow follow] - {[[(& ) (& )] {[]}] - [_ {}]})]}] - [ [integer] - {[ {fid}]}] - [ [integer] - {[ {tid}]}] - [$ [something] - {[$tgt {tgt}]}] - })) - -(define $follow-table (multiset follow)) - -;; -;; Demonstration code -;; -(define $user-data - { - - - }) - -(define $follow-data - { - - }) - -; Users whom "Egison_Lang" follows -(test (match-all [user-data follow-data user-data] [user-table follow-table user-table] - [[ ) _> - ) _> - ) _>] - ])) - -; Users who don't follow back "Egison_Lang" -(test (match-all [user-data follow-data user-data] [user-table follow-table user-table] - [[ ) _> - ) - ^ ) - _>> - ) _>] - ])) - -; Users who have interested in "Haskell" in the followers of followers of "Egison_Lang" -(test (match-all [user-data follow-data user-data] [user-table follow-table user-table] - [[ ) _> - ) - ) - _>> - > $txt)> ) _>] - ]))