egison 3.2.9 → 3.2.10

raw patch · 7 files changed

+129/−35 lines, 7 filesdep +mysqlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: mysql

API changes (from Hackage documentation)

Files

• egison.cabal +3/−3
• hs-src/Language/Egison.hs +2/−0
• hs-src/Language/Egison/Core.hs +28/−21
• hs-src/Language/Egison/Primitives.hs +43/−11
• hs-src/Language/Egison/Types.hs +2/−0
• lib/core/database.egi +35/−0
• lib/core/string.egi +16/−0

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -333,6 +333,8 @@ -- Pattern Match -- +data PMMode = BFSMode | DFSMode+ data MatchingState = MState Env [LoopContext] [Binding] [MatchingTree]  data MatchingTree =

@@ -0,0 +1,35 @@+;;;+;;; Database.egi+;;;++(define $database-table+  (algebraic-data-matcher+    {<database-table string string>}))++(define $database-name+  (lambda [$data]+    (match data database-table+      {[<database-table $n _> n]})))++(define $table-name+  (lambda [$data]+    (match data database-table+      {[<database-table _ $n> 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])+                                 {[<nil> ""]+                                  [<cons [$key $val] $rs>+                                   {{@key @" = " @val} @(loop-fn rs)}]}))]}+      (match (loop-fn wheres) (list string)+        {[<nil> ""]+         [<cons $wc $wcs> {@"where " @(concat (insert-between {wc @wcs} " and "))}]}))))

@@ -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]+          <cons $c_i <snoc ,c_i ...>>+          (| <nil> <cons $cm <nil>>))+        #t]+       [_ #f]})))