diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.0.3 +Version: 3.0.4 Synopsis: An Interpreter for the Programming Language Egison Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility. diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -4,7 +4,7 @@ ;;; Author: Satoshi Egi ;;; URL: https://github.com/egisatoshi/egison3/blob/master/elisp/egison-mode.el -;;; Version: 0.1.3 +;;; Version: 0.1.4 ;; Code goes here @@ -27,8 +27,8 @@ "\\" "\\" "\\" - "\\" - "\\" + "\\" + "\\" "\\" "\\" @@ -126,8 +126,7 @@ ((equal "matcher" name) 2) ((equal "algebraic-data-matcher" name) 2) ((equal "generate-array" name) 2) - ((equal "index-loop" name) 2) - ((equal "pattern-constructor" name) 2) + ((equal "pattern-function" name) 2) )) (defun egison-indent-line () 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 @@ -67,8 +67,8 @@ exprs <- liftEgisonM $ readTopExprs input concat <$> mapM recursiveLoad exprs where - recursiveLoad (Load file) = loadFile file - recursiveLoad (LoadFile file) = loadLibraryFile file + recursiveLoad (Load file) = loadLibraryFile file + recursiveLoad (LoadFile file) = loadFile file recursiveLoad expr = return [expr] loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] @@ -357,6 +357,8 @@ processMState (MState env loops bindings ((MAtom pattern target matcher):trees)) = do let env' = extendEnv env (bindings ++ map (\(LoopContext binding _ _ _) -> binding) loops) case pattern of + WildCard -> return $ msingleton $ MState env loops bindings trees + VarPat _ -> throwError $ strMsg "cannot use variable except in pattern function" ApplyPat func args -> do func <- evalExpr env' func @@ -367,7 +369,7 @@ _ -> throwError $ TypeMismatch "pattern constructor" func LoopPat name range pat pat' -> do - result <- runMaybeT $ lift (evalExpr env range) >>= unconsCollection' + result <- runMaybeT $ lift (evalExpr env' range >>= newEvaluatedThunk) >>= unconsCollection case result of Nothing -> return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees) Just (head, tail) -> @@ -384,51 +386,18 @@ let loops' = LoopContext (name, head) tail pat pat' : loops in return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees) - IndexedPat (PatVar name) indices -> do - indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices - case lookup name bindings of - Just ref -> do - obj <- evalRef ref >>= flip updateArray indices >>= newEvaluatedThunk - return $ msingleton $ MState env loops (subst name obj bindings) trees - Nothing -> do - obj <- updateArray (Value $ Array IntMap.empty) indices >>= newEvaluatedThunk - return $ msingleton $ MState env loops ((name, obj):bindings) trees - where - updateArray :: WHNFData -> [Int] -> EgisonM WHNFData - updateArray (Intermediate (IArray ary)) [index] = - return . Intermediate . IArray $ IntMap.insert index target ary - updateArray (Intermediate (IArray ary)) (index:indices) = do - val <- maybe (return $ Value $ Array IntMap.empty) evalRef $ IntMap.lookup index ary - ref <- updateArray val indices >>= newEvaluatedThunk - return . Intermediate . IArray $ IntMap.insert index ref ary - updateArray (Value (Array ary)) [index] = do - keys <- return $ IntMap.keys ary - vals <- mapM (newEvaluatedThunk . Value) $ IntMap.elems ary - return . Intermediate . IArray $ IntMap.insert index target (IntMap.fromList $ zip keys vals) - updateArray (Value (Array ary)) (index:indices) = do - let val = Value $ fromMaybe (Array IntMap.empty) $ IntMap.lookup index ary - ref <- updateArray val indices >>= newEvaluatedThunk - keys <- return $ IntMap.keys ary - vals <- mapM (newEvaluatedThunk . Value) $ IntMap.elems ary - return . Intermediate . IArray $ IntMap.insert index ref (IntMap.fromList $ zip keys vals) - subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)] - subst k nv ((k', v'):xs) | k == k' = (k', nv):(subst k nv xs) - | otherwise = (k', v'):(subst k nv xs) - subst _ _ [] = [] - IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) TuplePat patterns -> do matchers <- fromTuple matcher >>= mapM evalRef targets <- evalRef target >>= fromTuple let trees' = zipWith3 MAtom patterns targets matchers ++ trees return $ msingleton $ MState env loops bindings trees' - WildCard -> return $ msingleton $ MState env loops bindings trees AndPat patterns -> let trees' = map (\pattern -> MAtom pattern target matcher) patterns ++ trees in return $ msingleton $ MState env loops bindings trees' OrPat patterns -> return $ fromList $ flip map patterns $ \pattern -> MState env loops bindings (MAtom pattern target matcher : trees) - NotPat pattern -> do + NotPat pattern -> do -- TEMPORARY do not run in the pattern function results <- processMState (MState env loops bindings [MAtom pattern target matcher]) case results of MNil -> return $ msingleton $ MState env loops bindings trees @@ -447,7 +416,42 @@ case pattern of PatVar name -> do return $ msingleton $ MState env loops ((name, target):bindings) trees + + IndexedPat (PatVar name) indices -> do + indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices + case lookup name bindings of + Just ref -> do + obj <- evalRef ref >>= flip updateArray indices >>= newEvaluatedThunk + return $ msingleton $ MState env loops (subst name obj bindings) trees + Nothing -> do + obj <- updateArray (Value $ Array IntMap.empty) indices >>= newEvaluatedThunk + return $ msingleton $ MState env loops ((name, obj):bindings) trees + where + updateArray :: WHNFData -> [Int] -> EgisonM WHNFData + updateArray (Intermediate (IArray ary)) [index] = + return . Intermediate . IArray $ IntMap.insert index target ary + updateArray (Intermediate (IArray ary)) (index:indices) = do + val <- maybe (return $ Value $ Array IntMap.empty) evalRef $ IntMap.lookup index ary + ref <- updateArray val indices >>= newEvaluatedThunk + return . Intermediate . IArray $ IntMap.insert index ref ary + updateArray (Value (Array ary)) [index] = do + keys <- return $ IntMap.keys ary + vals <- mapM (newEvaluatedThunk . Value) $ IntMap.elems ary + return . Intermediate . IArray $ IntMap.insert index target (IntMap.fromList $ zip keys vals) + updateArray (Value (Array ary)) (index:indices) = do + let val = Value $ fromMaybe (Array IntMap.empty) $ IntMap.lookup index ary + ref <- updateArray val indices >>= newEvaluatedThunk + keys <- return $ IntMap.keys ary + vals <- mapM (newEvaluatedThunk . Value) $ IntMap.elems ary + return . Intermediate . IArray $ IntMap.insert index ref (IntMap.fromList $ zip keys vals) + subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)] + subst k nv ((k', v'):xs) | k == k' = (k', nv):(subst k nv xs) + | otherwise = (k', v'):(subst k nv xs) + subst _ _ [] = [] + IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) + _ -> throwError $ strMsg "something can only match with a pattern variable" + Value (Matcher matcher) -> do (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher mfor targetss $ \ref -> do @@ -466,7 +470,7 @@ Just pattern -> return $ msingleton $ MState env loops bindings (MAtom pattern target matcher:MNode penv (MState env' loops' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name - IndexedPat (VarPat name) indices -> -- cannot use multiple indices + IndexedPat (VarPat name) indices -> -- TEMPORARY cannot use multiple indices case lookup name penv of Just pattern -> do let env'' = extendEnv env' (bindings' ++ map (\(LoopContext binding _ _ _) -> binding) loops') @@ -566,25 +570,25 @@ unconsCollection :: ObjectRef -> MatchM (ObjectRef, ObjectRef) unconsCollection ref = lift (evalRef ref) >>= unconsCollection' - -unconsCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef) -unconsCollection' (Value (Collection col)) = - case Sq.viewl col of - EmptyL -> matchFail - val :< vals -> - lift $ (,) <$> newEvaluatedThunk (Value val) - <*> newEvaluatedThunk (Value $ Collection vals) -unconsCollection' (Intermediate (ICollection ic)) = - case Sq.viewl ic of - EmptyL -> matchFail - (IElement ref') :< inners -> - lift $ (ref', ) <$> newEvaluatedThunk (Intermediate $ ICollection inners) - (ISubCollection ref') :< inners -> do - inners' <- lift $ evalRef ref' >>= expandCollection - let coll = Intermediate (ICollection (inners' >< inners)) - lift $ writeThunk ref' coll - unconsCollection' coll -unconsCollection' _ = matchFail + where + unconsCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef) + unconsCollection' (Value (Collection col)) = + case Sq.viewl col of + EmptyL -> matchFail + val :< vals -> + lift $ (,) <$> newEvaluatedThunk (Value val) + <*> newEvaluatedThunk (Value $ Collection vals) + unconsCollection' (Intermediate (ICollection ic)) = + case Sq.viewl ic of + EmptyL -> matchFail + (IElement ref') :< inners -> + lift $ (ref', ) <$> newEvaluatedThunk (Intermediate $ ICollection inners) + (ISubCollection ref') :< inners -> do + inners' <- lift $ evalRef ref' >>= expandCollection + let coll = Intermediate (ICollection (inners' >< inners)) + lift $ writeThunk ref coll + unconsCollection' coll + unconsCollection' _ = matchFail unsnocCollection :: ObjectRef -> MatchM (ObjectRef, ObjectRef) unsnocCollection ref = lift (evalRef ref) >>= unsnocCollection' diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -59,6 +59,10 @@ [ {n}] [ {}]}))) +(define $from + (lambda [$m] + {m @(from (+ m 1))})) + (define $min (lambda [$ns] (match ns (list integer)