egison 3.2.16 → 3.2.17
raw patch · 8 files changed
+66/−201 lines, 8 filesdep +direct-sqlite
Dependencies added: direct-sqlite
Files
- egison.cabal +2/−2
- hs-src/Language/Egison/Primitives.hs +35/−66
- hs-src/Language/Egison/Types.hs +2/−2
- lib/core/base.egi +6/−12
- lib/core/database.egi +5/−0
- lib/core/number.egi +2/−32
- lib/core/order.egi +14/−6
- sample/social-graph.egi +0/−81
egison.cabal view
@@ -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
hs-src/Language/Egison/Primitives.hs view
@@ -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'+
hs-src/Language/Egison/Types.hs view
@@ -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 =
lib/core/base.egi view
@@ -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]
lib/core/database.egi view
@@ -33,3 +33,8 @@ (match (loop-fn wheres) (list string) {[<nil> ""] [<cons $wc $wcs> {@"where " @(intercalate " and " {wc @wcs})}]}))))++;;+;; for SQLite+;;+(define $pure-sqlite (lambda [$q] (io (sqlite q))))
lib/core/number.egi view
@@ -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)- <Less>- (if (eq? m n)- <Equal>- <Greater>))))+(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)- <Less>- (if (eq? d1 d2)- <Equal>- <Greater>))))+(define $float buildin-data-matcher)
lib/core/order.egi view
@@ -8,24 +8,32 @@ (algebraic-data-matcher {<less> <equal> <greater>})) +(define $compare+ (lambda [$m $n]+ (if (lt? m n)+ <Less>+ (if (eq? m n)+ <Equal>+ <Greater>))))+ (define $split-by-ordering- (lambda [$compare]+ (lambda [$compare-fn] (lambda [$xs $p] (match xs (list something) {[<nil> [{} {} {}]] [<cons $x $rs>- (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 {[<less> [{x @ys1} ys2 ys3]] [<equal> [ys1 {x @ys2} ys3]] [<greater> [ys1 ys2 {x @ys3}]]}))]})))) (define $qsort- (lambda [$compare]+ (lambda [$compare-fn] (match-lambda (list something) {[<nil> {}] [<cons $x <nil>> {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)})))]})))
− sample/social-graph.egi
@@ -1,81 +0,0 @@-;;;-;;;-;;; Social-graph Demonstration-;;;-;;;--;;-;; Matcher definition-;;-(define $user- (matcher- {[,$u []- {[$tgt (match [u tgt] [user user]- {[[<id $id> <id ,id>] {[]}]- [_ {}]})]}]- [<id $> [integer]- {[<User $id _ _> {id}]}]- [<name $> [string]- {[<User _ $name _> {name}]}]- [<description $> [string]- {[<User _ _ $txt> {txt}]}]- [$ [something]- {[$tgt {tgt}]}]- }))--(define $user-table (multiset user))--(define $follow- (matcher- {[,$f []- {[$tgt (match [f tgt] [follow follow]- {[[(& <from-id $fid> <to-id $tid>) (& <from-id ,fid> <to-id ,tid>)] {[]}]- [_ {}]})]}]- [<from-id $> [integer]- {[<Follow $fid _> {fid}]}]- [<to-id $> [integer]- {[<Follow _ $tid> {tid}]}]- [$ [something]- {[$tgt {tgt}]}]- }))--(define $follow-table (multiset follow))--;;-;; Demonstration code-;;-(define $user-data- {<User 1 "Egison_Lang" "The Programming Language Egison.\nThe pattern-matching-oriented pure functional programming language.">- <User 2 "RakutenRIT" "Rakuten Institute of Technology">- <User 3 "Haskeller" "I love Haskell programming.">- })--(define $follow-data- {<Follow 1 2>- <Follow 2 3>- })--; Users whom "Egison_Lang" follows-(test (match-all [user-data follow-data user-data] [user-table follow-table user-table]- [[<cons (& <name ,"Egison_Lang"> <id $uid>) _>- <cons (& <from-id ,uid> <to-id $fid>) _>- <cons (& <id ,fid> <name $name> <description $txt>) _>]- <User fid name txt>]))--; Users who don't follow back "Egison_Lang"-(test (match-all [user-data follow-data user-data] [user-table follow-table user-table]- [[<cons (& <name ,"Egison_Lang"> <id $uid>) _>- <cons (& <from-id ,uid> <to-id $fid>)- ^<cons (& <from-id ,fid> <to-id ,uid>)- _>>- <cons (& <id ,fid> <name $name> <description $txt>) _>]- <User fid name txt>]))--; 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]- [[<cons (& <name ,"Egison_Lang"> <id $uid>) _>- <cons (& <from-id ,uid> <to-id $fid>)- <cons (& <from-id ,fid> <to-id $ffid>)- _>>- <cons (& <id ,ffid> <description (& <join _ <join ,"Haskell" _>> $txt)> <name $name>) _>]- <User ffid name txt>]))