diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.1.0 +Version: 3.1.1 Synopsis: The world's first language with non-linear pattern-matching against unfree data Description: An interpreter for Egison, the world's first programming langugage which realized non-linear pattern-matching with unfree data types. With Egison, you can represent pattern-matching with unfree data types intuitively, 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 @@ -17,7 +17,7 @@ import Data.Maybe import qualified Data.HashMap.Lazy as HL -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 @@ -63,7 +63,7 @@ return env evalTopExpr env (Execute argv) = do main <- refVar env "main" >>= evalRef - io <- applyFunc main $ Value $ Collection $ Sq.fromList $ map (String . B.pack) argv + io <- applyFunc main $ Value $ Collection $ Sq.fromList $ map makeStringValue argv case io of Value (IOFunc m) -> m >> return env _ -> throwError $ TypeMismatch "io" io @@ -72,7 +72,7 @@ evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c -evalExpr _ (StringExpr s) = return . Value $ String $ B.pack s +evalExpr _ (StringExpr s) = return $ Value $ makeStringValue s evalExpr _ (BoolExpr b) = return . Value $ Bool b evalExpr _ (IntegerExpr i) = return . Value $ Integer i evalExpr _ (FloatExpr d) = return . Value $ Float d @@ -104,9 +104,17 @@ evalExpr env (HashExpr assocs) = do let (keyExprs, exprs) = unzip assocs keyVals <- mapM (evalExpr' env) keyExprs - keys <- mapM makeKey keyVals + keys <- liftError $ mapM makeKey keyVals refs <- mapM (newThunk env) exprs - return . Intermediate . IHash $ HL.fromList $ zip keys refs + case head keys of + IntKey _ -> do + let keys' = map (\key -> case key of + IntKey i -> i) keys + return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs + StrKey _ -> do + let keys' = map (\key -> case key of + StrKey s -> s) keys + return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs evalExpr env (IndexedExpr expr indices) = do array <- evalExpr env expr @@ -125,16 +133,26 @@ case IntMap.lookup i array of Just ref -> evalRef ref >>= flip refArray indices Nothing -> return $ Value Undefined - refArray (Value (Hash hash)) (index:indices) = do - key <- makeKey index + refArray (Value (IntHash hash)) (index:indices) = do + key <- liftError $ fromIntegerValue $ Value index case HL.lookup key hash of Just val -> refArray (Value val) indices Nothing -> return $ Value Undefined - refArray (Intermediate (IHash hash)) (index:indices) = do - key <- makeKey index + refArray (Intermediate (IIntHash hash)) (index:indices) = do + key <- liftError $ fromIntegerValue $ Value index case HL.lookup key hash of Just ref -> evalRef ref >>= flip refArray indices Nothing -> return $ Value Undefined + refArray (Value (StrHash hash)) (index:indices) = do + key <- liftError $ fromStringValue $ Value index + case HL.lookup (B.pack key) hash of + Just val -> refArray (Value val) indices + Nothing -> return $ Value Undefined + refArray (Intermediate (IStrHash hash)) (index:indices) = do + key <- liftError $ fromStringValue $ Value index + case HL.lookup (B.pack key) hash of + Just ref -> evalRef ref >>= flip refArray indices + Nothing -> return $ Value Undefined refArray val _ = throwError $ TypeMismatch "array" val evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr @@ -265,9 +283,12 @@ evalDeep (Intermediate (IArray refs)) = do refs' <- mapM evalRef' $ IntMap.elems refs return $ Array $ IntMap.fromList $ zip (enumFromTo 1 (IntMap.size refs)) refs' -evalDeep (Intermediate (IHash refs)) = do +evalDeep (Intermediate (IIntHash refs)) = do refs' <- mapM evalRef' refs - return $ Hash refs' + return $ IntHash refs' +evalDeep (Intermediate (IStrHash refs)) = do + refs' <- mapM evalRef' refs + return $ StrHash refs' evalDeep (Intermediate (ITuple refs)) = Tuple <$> mapM evalRef' refs evalDeep coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRef' . Sq.fromList) 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 @@ -15,6 +15,7 @@ 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 Language.Egison.Types import Language.Egison.Core @@ -211,8 +212,8 @@ stringAppend :: PrimitiveFunc -stringAppend = (liftError .) $ twoArgs $ \val val' -> - (String .) . BL.append <$> fromStringValue val +stringAppend = (liftError .) $ twoArgs $ \val val' -> do + (makeStringValue .) . (++) <$> fromStringValue val <*> fromStringValue val' assert :: PrimitiveFunc @@ -276,7 +277,7 @@ makePort :: IOMode -> PrimitiveFunc makePort mode = (liftError .) $ oneArg $ \val -> do filename <- fromStringValue val - return . makeIO . liftIO $ Port <$> openFile (B.unpack filename) mode + return . makeIO . liftIO $ Port <$> openFile filename mode closePort :: PrimitiveFunc closePort = (liftError .) $ oneArg $ \val -> @@ -288,7 +289,7 @@ writeString :: PrimitiveFunc writeString = (liftError .) $ oneArg $ \val -> - makeIO' . liftIO . putStr . B.unpack <$> fromStringValue val + makeIO' . liftIO . putStr <$> fromStringValue val write :: PrimitiveFunc write = oneArg $ \val -> @@ -298,7 +299,7 @@ readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar readLine :: PrimitiveFunc -readLine = noArg $ return $ makeIO $ liftIO $ liftM (String . B.pack) getLine +readLine = noArg $ return $ makeIO $ liftIO $ liftM makeStringValue getLine flushStdout :: PrimitiveFunc flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout @@ -312,7 +313,7 @@ writeStringToPort :: PrimitiveFunc writeStringToPort = (liftError .) $ twoArgs $ \val val' -> - ((makeIO' . liftIO) .) . hPutStr <$> fromPortValue val <*> (B.unpack <$> fromStringValue val') + ((makeIO' . liftIO) .) . hPutStr <$> fromPortValue val <*> fromStringValue val' writeToPort :: PrimitiveFunc writeToPort = twoArgs $ \val val' -> do @@ -325,7 +326,7 @@ readLineFromPort :: PrimitiveFunc readLineFromPort = (liftError .) $ oneArg $ \val -> - makeIO . liftIO . liftM (String . B.pack) . hGetLine <$> fromPortValue val + makeIO . liftIO . liftM makeStringValue . hGetLine <$> fromPortValue val flushPort :: PrimitiveFunc flushPort = (liftError .) $ oneArg $ \val -> 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 @@ -136,7 +136,6 @@ data EgisonValue = World | Char Char - | String ByteString | Bool Bool | Integer Integer | Float Double @@ -144,7 +143,8 @@ | Tuple [EgisonValue] | Collection (Seq EgisonValue) | Array (IntMap EgisonValue) - | Hash (HashMap ByteString EgisonValue) + | IntHash (HashMap Integer EgisonValue) + | StrHash (HashMap ByteString EgisonValue) | Matcher Matcher | Func Env [String] EgisonExpr | PatternFunc Env [String] EgisonPattern @@ -159,8 +159,7 @@ type PrimitiveFunc = [WHNFData] -> EgisonM EgisonValue instance Show EgisonValue where - show (Char c) = return c - show (String s) = "\"" ++ B.unpack s ++ "\"" + show (Char c) = show c show (Bool True) = "#t" show (Bool False) = "#f" show (Integer i) = show i @@ -170,7 +169,8 @@ show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]" show (Collection vals) = "{" ++ unwords (map show (toList vals)) ++ "}" show (Array vals) = "[|" ++ unwords (map show $ IntMap.elems vals) ++ "|]" - show (Hash hash) = "{|" ++ unwords (map (\(key, val) -> B.unpack key ++ " " ++ show val) $ HashMap.toList hash) ++ "|}" + show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" + show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ B.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (Matcher _) = "#" show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)" show (PatternFunc _ _ _) = "#" @@ -184,7 +184,6 @@ instance Eq EgisonValue where (Char c) == (Char c') = c == c' - (String s) == (String s') = s == s' (Bool b) == (Bool b') = b == b' (Integer i) == (Integer i') = i == i' (Float f) == (Float f') = f == f' @@ -194,12 +193,6 @@ (Collection vals) == (Collection vals') = vals == vals' _ == _ = False -makeKey :: EgisonValue -> EgisonM ByteString -makeKey (Integer i) = return $ B.pack $ show i -makeKey (Char i) = return $ B.pack $ show i -makeKey (String s) = return s -makeKey val = throwError $ TypeMismatch "integer, char or string" (Value val) - -- -- Internal Data -- @@ -219,7 +212,8 @@ | ITuple [ObjectRef] | ICollection (Seq Inner) | IArray (IntMap ObjectRef) - | IHash (HashMap ByteString ObjectRef) + | IIntHash (HashMap Integer ObjectRef) + | IStrHash (HashMap ByteString ObjectRef) data Inner = IElement ObjectRef @@ -231,16 +225,38 @@ show (Intermediate (ITuple _)) = "[...]" show (Intermediate (ICollection _)) = "{...}" show (Intermediate (IArray _)) = "[|...|]" - show (Intermediate (IHash _)) = "{|...|}" + show (Intermediate (IIntHash _)) = "{|...|}" + show (Intermediate (IStrHash _)) = "{|...|}" +data EgisonHashKey = + IntKey Integer + | StrKey ByteString + +makeKey :: EgisonValue -> Either EgisonError EgisonHashKey +makeKey val = + case val of + Integer i -> return (IntKey i) + Collection _ -> do + str <- fromStringValue $ Value val + return $ StrKey $ B.pack str + _ -> throwError $ TypeMismatch "integer or string" $ Value val + fromCharValue :: WHNFData -> Either EgisonError Char fromCharValue (Value (Char c)) = return c fromCharValue val = throwError $ TypeMismatch "char" val -fromStringValue :: WHNFData -> Either EgisonError ByteString -fromStringValue (Value (String s)) = return s +fromStringValue :: WHNFData -> Either EgisonError String +fromStringValue (Value (Collection seq)) = do + let ls = toList seq + mapM (\val -> case val of + Char c -> return c + _ -> throwError $ TypeMismatch "char" (Value val)) + ls fromStringValue val = throwError $ TypeMismatch "string" val +makeStringValue :: String -> EgisonValue +makeStringValue str = Collection $ Sq.fromList $ map Char str + fromBoolValue :: WHNFData -> Either EgisonError Bool fromBoolValue (Value (Bool b)) = return b fromBoolValue val = throwError $ TypeMismatch "bool" val @@ -263,7 +279,6 @@ fromPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue fromPrimitiveValue (Value val@(Char _)) = return val -fromPrimitiveValue (Value val@(String _)) = return val fromPrimitiveValue (Value val@(Bool _)) = return val fromPrimitiveValue (Value val@(Integer _)) = return val fromPrimitiveValue (Value val@(Float _)) = return val diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -40,16 +40,6 @@ {[$tgt {tgt}]}] })) -(define $string - (matcher - {[,$s [] - {[$tgt (if (eq? tgt s) - {[]} - {})]}] - [$ [something] - {[$tgt {tgt}]}] - })) - (define $ordering (algebraic-data-matcher { })) diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -49,6 +49,8 @@ {[$tgt {tgt}]}] }))) +(define $string (list char)) + (define $map (lambda [$fn $ls] (match ls (list something)