diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.2.20 +Version: 3.2.21 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 against unfree data types. @@ -36,7 +36,7 @@ source-repository head type: git - location: https://github.com/egisatoshi/egison3.git + location: https://github.com/egisatoshi/egison.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, text, regex-posix, direct-sqlite diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -36,6 +36,9 @@ "\\" "\\" "\\" + "\\" + "\\" + "\\" "\\" "\\" @@ -145,6 +148,8 @@ ((equal "next-match-all" name) 2) ((equal "next-match-all-lambda" name) 2) ((equal "matcher" name) 2) + ((equal "matcher-bfs" name) 2) + ((equal "matcher-dfs" name) 2) ((equal "algebraic-data-matcher" name) 2) ((equal "pattern-function" name) 2) ((equal "do" name) 2) diff --git a/hs-src/Interpreter/egisoni.hs b/hs-src/Interpreter/egisoni.hs --- a/hs-src/Interpreter/egisoni.hs +++ b/hs-src/Interpreter/egisoni.hs @@ -1,5 +1,6 @@ module Main where +import Prelude hiding ( catch ) import Control.Exception ( AsyncException(..), catch ) import Control.Monad.Error 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 @@ -391,7 +391,7 @@ newThunk env expr = Thunk $ evalExpr env expr newObjectRef :: Env -> EgisonExpr -> EgisonM ObjectRef -newObjectRef env expr = liftIO . newIORef . Thunk $ evalExpr env expr +newObjectRef env expr = liftIO $ newIORef $ newThunk env expr writeObjectRef :: ObjectRef -> WHNFData -> EgisonM () writeObjectRef ref val = liftIO . writeIORef ref $ WHNF val @@ -427,9 +427,9 @@ where processMStates' :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState] processMStates' MNil = return [] - processMStates' stream@(MCons state _) = do + processMStates' stream@(MCons state _) = case topMAtom state of - Nothing -> processMStatesBFS stream + Nothing -> processMStatesDFS stream Just matom -> do case pmMode (getMatcher matom) of DFSMode -> processMStatesDFS stream @@ -593,7 +593,7 @@ Just ref -> do obj <- evalRef ref >>= updateHash indices >>= newEvalutedObjectRef return $ msingleton $ MState env loops (subst name obj bindings) trees - Nothing -> do + Nothing -> do -- throwError $ strMsg "Cannot reach here!\nIndexed-patttern-variable does not initialized." obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvalutedObjectRef return $ msingleton $ MState env loops ((name,obj):bindings) trees where diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -223,7 +223,15 @@ desugar (VarExpr name) = do asks $ maybe (VarExpr name) id . lookup name + +desugar (MatcherBFSExpr matcherInfo) = do + matcherInfo' <- desugarMatcherInfo matcherInfo + return $ MatcherBFSExpr matcherInfo' +desugar (MatcherDFSExpr matcherInfo) = do + matcherInfo' <- desugarMatcherInfo matcherInfo + return $ MatcherDFSExpr matcherInfo' + desugar expr = return expr desugarPattern :: EgisonPattern -> DesugarM EgisonPattern @@ -301,3 +309,18 @@ rest' <- desugarMatchClauses rest return $ clause' : rest' desugarMatchClauses [] = return [] + +desugarMatcherInfo :: MatcherInfo -> DesugarM MatcherInfo +desugarMatcherInfo [] = return [] +desugarMatcherInfo ((pp, matcher, pds):matcherInfo) = do + matcher' <- desugar matcher + pds' <- desugarPrimitiveDataMatchClauses pds + matcherInfo' <- desugarMatcherInfo matcherInfo + return $ (pp, matcher', pds'):matcherInfo' + +desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> DesugarM [(PrimitiveDataPattern, EgisonExpr)] +desugarPrimitiveDataMatchClauses [] = return [] +desugarPrimitiveDataMatchClauses ((pd, expr):pds) = do + expr' <- desugar expr + pds' <- desugarPrimitiveDataMatchClauses pds + return $ (pd, expr'):pds' 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 @@ -271,7 +271,8 @@ show (Array vals) = "[|" ++ unwords (map show $ IntMap.elems vals) ++ "|]" 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 (UserMatcher _ _ _) = "#" + show (UserMatcher _ BFSMode _) = "#" + show (UserMatcher _ DFSMode _) = "#" show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)" show (PatternFunc _ _ _) = "#" show (PrimitiveFunc _) = "#" @@ -506,23 +507,27 @@ type Match = [Binding] data PMMode = BFSMode | DFSMode + deriving (Show) pmMode :: Matcher -> PMMode pmMode (UserMatcher _ mode _) = mode -pmMode (Tuple _) = BFSMode -pmMode Something = BFSMode +pmMode (Tuple _) = DFSMode +pmMode Something = DFSMode data MatchingState = MState Env [LoopContext] [Binding] [MatchingTree] + deriving (Show) data MatchingTree = MAtom EgisonPattern ObjectRef Matcher | MNode [PatternBinding] MatchingState + deriving (Show) type PatternBinding = (Var, EgisonPattern) data LoopContext = LoopContextConstant Binding Integer EgisonPattern EgisonPattern | LoopContextVariable Binding EgisonPattern EgisonPattern EgisonPattern + deriving (Show) -- -- Errors diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -3,7 +3,7 @@ ;; (define $buildin-data-matcher - (matcher + (matcher-dfs {[,$val [] {[$tgt (if (eq? val tgt) {[]} diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -7,7 +7,7 @@ ;;; (define $list (lambda [$a] - (matcher + (matcher-bfs {[,$val [] {[$tgt (match [val tgt] [(list a) (list a)] {[[ ] {[]}] @@ -37,6 +37,43 @@ rs])]}] [ [(list a) (list a)] {[$tgt (match-all tgt (list a) + [(loop $i [1 $n] $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}] + [$ [something] + {[$tgt {tgt}]}] + }))) + +(define $flist + (lambda [$a] + (matcher-dfs + {[,$val [] + {[$tgt (match [val tgt] [(flist a) (flist a)] + {[[ ] {[]}] + [[ ] {[]}] + [[_ _] {}]})]}] + [ [] + {[{} {[]}] + [_ {}]}] + [ [a (flist a)] + {[{$x @$xs} {[x xs]}] + [_ {}]}] + [ [a (flist a)] + {[{@$xs $x} {[x xs]}] + [_ {}]}] + [ [(flist a)] + {[$tgt (match-all [pxs tgt] [(flist a) (flist a)] + [[(loop $i [1 $n] ) + (loop $i [1 ,n] $rs)] + rs])]}] + [ [(flist a) (flist a)] + {[$tgt (match-all tgt (flist a) + [(loop $i [1 $n] $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}] + [ [(flist a)] + {[$tgt (match-all [pxs tgt] [(flist a) (flist a)] + [[(loop $i [1 $n] ) + (loop $i [1 ,n] $rs)] + rs])]}] + [ [(flist a) (flist a)] + {[$tgt (match-all tgt (flist a) [(loop $i [1 $n] $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}] [$ [something] {[$tgt {tgt}]}]