egison 3.0.3 → 3.0.4
raw patch · 4 files changed
+70/−63 lines, 4 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Language.Egison.Core: unconsCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef)
Files
- egison.cabal +1/−1
- elisp/egison-mode.el +4/−5
- hs-src/Language/Egison/Core.hs +61/−57
- lib/core/number.egi +4/−0
egison.cabal view
@@ -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.
elisp/egison-mode.el view
@@ -4,7 +4,7 @@ ;;; Author: Satoshi Egi <egisatoshi@gmail.com> ;;; 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 @@ "\\<function\\>" "\\<match\\>" "\\<match-all\\>"- "\\<index-loop\\>"- "\\<pattern-constructor\\>"+ "\\<pattern-function\\>"+ "\\<generate-array\\>" "\\<undefined\\>" "\\<something\\>"@@ -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 ()
hs-src/Language/Egison/Core.hs view
@@ -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'
lib/core/number.egi view
@@ -59,6 +59,10 @@ [<equal> {n}] [<greater> {}]}))) +(define $from+ (lambda [$m]+ {m @(from (+ m 1))}))+ (define $min (lambda [$ns] (match ns (list integer)