diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.2.9 +Version: 3.2.10 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 with unfree data types. With Egison, you can represent pattern-matching with unfree data types intuitively, @@ -17,7 +17,7 @@ Extra-Source-Files: benchmark/Benchmark.hs -Data-files: lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi +Data-files: lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi lib/core/string.egi lib/core/database.egi lib/tree/xml.egi lib/math/prime.egi elisp/egison-mode.el @@ -26,7 +26,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 + Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, bytestring, mysql Hs-Source-Dirs: hs-src Exposed-Modules: Language.Egison diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -68,6 +68,8 @@ , "lib/core/order.egi" , "lib/core/number.egi" , "lib/core/natural-number.egi" + , "lib/core/string.egi" + , "lib/core/database.egi" ] fromEgisonM :: EgisonM a -> IO (Either EgisonError a) diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -204,7 +204,7 @@ target <- newThunk env target matcher <- evalExpr env matcher - result <- patternMatch env pattern target matcher + result <- patternMatch BFSMode env pattern target matcher mmap (flip evalExpr expr . extendEnv env) result >>= fromMList where fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData @@ -218,7 +218,7 @@ target <- newThunk env target matcher <- evalExpr env matcher let tryMatchClause (pattern, expr) cont = do - result <- patternMatch env pattern target matcher + result <- patternMatch BFSMode env pattern target matcher case result of MCons bindings _ -> evalExpr (extendEnv env bindings) expr MNil -> cont @@ -302,8 +302,10 @@ if length names == length refs then evalExpr (extendEnv env $ makeBindings names refs) body else throwError $ ArgumentsNum (length names) (length refs) -applyFunc (Value (PrimitiveFunc func)) arg = - fromTuple arg >>= mapM evalRef >>= liftM Value . func +applyFunc (Value (PrimitiveFunc func)) arg = do +-- fromTuple arg >>= mapM evalRef >>= liftM Value . func + arg' <- fromTuple arg >>= mapM evalRef' + liftM Value . func $ map Value arg' applyFunc (Value (IOFunc m)) arg = do case arg of Value World -> m @@ -376,29 +378,34 @@ -- Pattern Match -- -patternMatch :: Env -> EgisonPattern -> ObjectRef -> WHNFData -> +patternMatch :: PMMode -> Env -> EgisonPattern -> ObjectRef -> WHNFData -> EgisonM (MList EgisonM [Binding]) -patternMatch env pattern target matcher = - processMState (MState env [] [] [MAtom pattern target matcher]) >>= processMStates . (:[]) +patternMatch mode env pattern target matcher = + processMState mode (MState env [] [] [MAtom pattern target matcher]) >>= (processMStates mode) . (:[]) -processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM [Binding]) -processMStates [] = return MNil -processMStates streams = do - let (bindings, streams') = (catMaybes *** concat) . unzip $ map processMStates' streams - mappend (fromList bindings) (sequence streams' >>= processMStates) - where - processMStates' :: MList EgisonM MatchingState -> - (Maybe [Binding], [EgisonM (MList EgisonM MatchingState)]) - processMStates' MNil = (Nothing, []) - processMStates' (MCons (MState _ _ bindings []) states) = (Just bindings, [states]) - processMStates' (MCons state states) = (Nothing, [processMState state, states]) +processMStates :: PMMode -> [MList EgisonM MatchingState] -> EgisonM (MList EgisonM [Binding]) +processMStates _ [] = return MNil +processMStates BFSMode streams = do + let (bindings, streams') = (catMaybes *** concat) . unzip $ map (processMStates' BFSMode) streams + mappend (fromList bindings) (sequence streams' >>= (processMStates BFSMode)) +processMStates DFSMode (stream:streams) = + case processMStates' DFSMode stream of + (Nothing, streams2) -> do streams' <- sequence streams2 + processMStates DFSMode (streams' ++ streams) + (Just bindings, streams2) -> do streams' <- sequence streams2 + mappend (fromList [bindings]) (processMStates DFSMode (streams' ++ streams)) -processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState) -processMState state = +processMStates' :: PMMode -> MList EgisonM MatchingState -> (Maybe [Binding], [EgisonM (MList EgisonM MatchingState)]) +processMStates' _ MNil = (Nothing, []) +processMStates' _ (MCons (MState _ _ bindings []) states) = (Just bindings, [states]) +processMStates' mode (MCons state states) = (Nothing, [processMState mode state, states]) + +processMState :: PMMode -> MatchingState -> EgisonM (MList EgisonM MatchingState) +processMState mode state = if isNotPat state then do let (state1, state2) = splitMState state - result <- processMStates [msingleton state1] + result <- processMStates mode [msingleton state1] case result of MNil -> return $ msingleton state2 _ -> return MNil 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 @@ -12,12 +12,16 @@ import System.IO import System.Random -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Lazy.Char8 () -import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Sequence as Sq +import System.IO.Unsafe +import qualified Database.MySQL.Base as MySQL +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC + +import Control.Monad + import Language.Egison.Types import Language.Egison.Core @@ -126,6 +130,7 @@ , ("itof", integerToFloat) , ("rtof", rationalToFloat) , ("itos", integerToString) + , ("stoi", stringToInteger) , ("eq?", eq) , ("lt?", lt) , ("lte?", lte) @@ -136,10 +141,12 @@ , ("*", multiply) , ("/", divide) , ("/-inverse", divideInverse) - , ("string-append", stringAppend) , ("assert", assert) - , ("assert-equal", assertEqual) ] + , ("assert-equal", assertEqual) + , ("pure-mysql", pureMySQL) + ] + integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc integerUnaryOp op = (liftError .) $ oneArg $ \val -> Integer . op <$> fromIntegerValue val @@ -184,6 +191,11 @@ integerToString = (liftError .) $ oneArg $ \val -> makeStringValue . show <$> fromIntegerValue val +stringToInteger :: PrimitiveFunc +stringToInteger = (liftError .) $ oneArg $ \val -> do + numStr <- fromStringValue val + return $ Integer (read numStr :: Integer) + eq :: PrimitiveFunc eq = (liftError .) $ twoArgs $ \val val' -> (Bool .) . (==) <$> fromPrimitiveValue val @@ -313,11 +325,6 @@ return $ Tuple [Integer x, Integer 1] divideInverse' val = throwError $ TypeMismatch "rational" val -stringAppend :: PrimitiveFunc -stringAppend = (liftError .) $ twoArgs $ \val val' -> do - (makeStringValue .) . (++) <$> fromStringValue val - <*> fromStringValue val' - assert :: PrimitiveFunc assert = (liftError .) $ twoArgs $ \label test -> do test <- fromBoolValue test @@ -333,6 +340,31 @@ then return $ Bool True else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual + + +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 makeStringValue 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' -- -- IO Primitives 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 @@ -333,6 +333,8 @@ -- Pattern Match -- +data PMMode = BFSMode | DFSMode + data MatchingState = MState Env [LoopContext] [Binding] [MatchingTree] data MatchingTree = diff --git a/lib/core/database.egi b/lib/core/database.egi new file mode 100644 --- /dev/null +++ b/lib/core/database.egi @@ -0,0 +1,35 @@ +;;; +;;; Database.egi +;;; + +(define $database-table + (algebraic-data-matcher + {})) + +(define $database-name + (lambda [$data] + (match data database-table + {[ n]}))) + +(define $table-name + (lambda [$data] + (match data database-table + {[ n]}))) + +;; +;; Generate SQL +;; +(define $simple-select + (lambda [$whats $table-name $wheres] + {@"select " @(concat (insert-between whats ", ")) @" from " @table-name @" " @(simple-where wheres)})) + +(define $simple-where + (lambda [$wheres] + (letrec {[$loop-fn (lambda [$wheres] + (match wheres (list [string something]) + {[ ""] + [ + {{@key @" = " @val} @(loop-fn rs)}]}))]} + (match (loop-fn wheres) (list string) + {[ ""] + [ {@"where " @(concat (insert-between {wc @wcs} " and "))}]})))) diff --git a/lib/core/string.egi b/lib/core/string.egi new file mode 100644 --- /dev/null +++ b/lib/core/string.egi @@ -0,0 +1,16 @@ +;;; +;;; String.egi +;;; + +(define $insert-between + (lambda [$ws $in] + (foldl (lambda [$s1 $s2] {@s1 in s2}) {(car ws)} (cdr ws)))) + +(define $palindrome? + (lambda [$str] + (match str string + {[(loop $i [1 $n] + > + (| >)) + #t] + [_ #f]})))