egison 3.1.1 → 3.2.0

raw patch · 11 files changed

+138/−129 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• egison.cabal +3/−3
• hs-src/Language/Egison.hs +1/−1
• hs-src/Language/Egison/Core.hs +43/−16
• hs-src/Language/Egison/Desugar.hs +10/−2
• hs-src/Language/Egison/Parser.hs +5/−1
• hs-src/Language/Egison/Types.hs +13/−2
• lib/core/collection.egi +22/−40
• lib/core/number.egi +5/−13
• lib/core/pattern.egi +0/−15
• lib/graph/graph.egi +12/−36
• lib/tree/tree.egi +24/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.1.1+Version:             3.2.0 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,@@ -17,8 +17,8 @@  Extra-Source-Files:  benchmark/Benchmark.hs -Data-files:          lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/core/pattern.egi-                     lib/graph/graph.egi lib/tree/xml.egi lib/math/prime.egi+Data-files:          lib/core/base.egi lib/core/number.egi lib/core/collection.egi+                     lib/graph/graph.egi lib/tree/tree.egi lib/tree/xml.egi lib/math/prime.egi                      elisp/egison-mode.el  Library

@@ -66,7 +66,7 @@     libraries = [ "lib/core/base.egi"                 , "lib/core/collection.egi"                 , "lib/core/number.egi"-                , "lib/core/pattern.egi" ]+                 ]  fromEgisonM :: EgisonM a -> IO (Either EgisonError a) fromEgisonM = modifyCounter . runEgisonM

@@ -418,7 +418,9 @@ processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState) processMState' state@(MState _ _ _ []) = throwError $ strMsg "should not reach here" processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)) = do-  let env' = extendEnv env (bindings ++ map (\(LoopContext binding _ _ _) -> binding) loops)+  let env' = extendEnv env (bindings ++ map (\lc -> case lc of+                                                      (LoopContextConstant binding _ _ _) -> binding+                                                      (LoopContextVariable binding _ _ _) -> binding) loops)   case pattern of     VarPat _ -> throwError $ strMsg "cannot use variable except in pattern function"     ApplyPat func args -> do@@ -429,23 +431,46 @@           in return $ msingleton $ MState env loops bindings (MNode penv (MState env'' [] [] [MAtom expr target matcher]) : trees)         _ -> throwError $ TypeMismatch "pattern constructor" func     -    LoopPat name range pat pat' -> do-      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) ->-          let loops' = LoopContext (name, head) tail pat pat' : loops -          in return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)+    LoopPat name (LoopRangeConstant start end) pat pat' -> do+      startNum' <- evalExpr' env' start+      startNum <- extractInteger startNum'+      endNum' <- evalExpr' env' end+      endNum <- extractInteger endNum'+      if startNum > endNum+        then do+          return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees)+        else do+          startNumRef <- liftIO . newIORef . WHNF $ Value $ Integer startNum+          let loops' = LoopContextConstant (name, startNumRef) endNum pat pat' : loops+          return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)+    LoopPat name (LoopRangeVariable start lastName) pat pat' -> do+      startNum' <- evalExpr' env' start+      startNum <- extractInteger startNum'+      startNumRef <- liftIO . newIORef . WHNF $ Value $ Integer startNum+      lastNumRef <- liftIO . newIORef . WHNF $ Value $ Integer (startNum - 1)+      return $ fromList [MState env loops ((lastName, lastNumRef):bindings) ((MAtom pat' target matcher):trees),+                         MState env ((LoopContextVariable (name, startNumRef) lastName pat pat'):loops) bindings ((MAtom pat target matcher):trees)]     ContPat ->       case loops of         [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern"-        LoopContext (name, _) coll pat pat' : loops -> do-          result <- runMaybeT $ unconsCollection coll-          case result of-            Nothing -> return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees)-            Just (head, tail) ->-              let loops' = LoopContext (name, head) tail pat pat' : loops -              in return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)+        LoopContextConstant (name, startNumRef) endNum pat pat' : loops -> do+          startNum' <- evalRef' startNumRef+          startNum <- extractInteger startNum'+          let nextNum = startNum + 1+          if nextNum > endNum+            then return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees)+            else do+              nextNumRef <- liftIO . newIORef . WHNF $ Value $ Integer nextNum+              let loops' = LoopContextConstant (name, nextNumRef) endNum pat pat' : loops +              return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)+        LoopContextVariable (name, startNumRef) lastName pat pat' : loops -> do+          startNum' <- evalRef' startNumRef+          startNum <- extractInteger startNum'+          let nextNum = startNum + 1+          nextNumRef <- liftIO . newIORef . WHNF $ Value $ Integer nextNum+          let loops' = LoopContextVariable (name, nextNumRef) lastName pat pat' : loops +          return $ fromList [MState env loops ((lastName, startNumRef):bindings) (MAtom pat' target matcher : trees),+                             MState env loops' bindings (MAtom pat target matcher : trees)]                TuplePat patterns -> do       matchers <- fromTuple matcher >>= mapM evalRef@@ -539,7 +564,9 @@         IndexedPat (VarPat name) indices ->           case lookup name penv of             Just pattern -> do-              let env'' = extendEnv env' (bindings' ++ map (\(LoopContext binding _ _ _) -> binding) loops')+              let env'' = extendEnv env' (bindings' ++ map (\lc -> case lc of+                                                                     (LoopContextConstant binding _ _ _) -> binding+                                                                     (LoopContextVariable binding _ _ _) -> binding) loops')               indices <- mapM (evalExpr env'' >=> liftError . liftM fromInteger . fromIntegerValue) indices               let pattern' = IndexedPat pattern $ map IntegerExpr indices               return $ msingleton $ MState env loops bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' bindings' trees'):trees)

@@ -221,14 +221,22 @@   IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs desugarPattern' (ApplyPat expr patterns) =   ApplyPat <$> desugar expr <*> mapM desugarPattern' patterns -desugarPattern' (LoopPat name expr pattern1 pattern2) =-  LoopPat name <$> desugar expr <*> desugarPattern' pattern1 <*> desugarPattern' pattern2+desugarPattern' (LoopPat name range pattern1 pattern2) =+  LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (LetPat binds pattern) = do   LetPat <$> desugarBindings binds <*> desugarPattern' pattern desugarPattern' (OrPat patterns)  =    OrPat <$> mapM desugarPattern' patterns desugarPattern' pattern = return pattern +desugarLoopRange :: LoopRange -> DesugarM LoopRange+desugarLoopRange (LoopRangeConstant expr1 expr2) = do+  expr1' <- desugar expr1+  expr2' <- desugar expr2+  return $ LoopRangeConstant expr1' expr2'+desugarLoopRange (LoopRangeVariable expr1 name) = do+  expr1' <- desugar expr1+  return $ LoopRangeVariable expr1' name  desugarBinding :: BindingExpr -> DesugarM BindingExpr desugarBinding (name, expr) = do

@@ -381,7 +381,11 @@ applyPat = ApplyPat <$> expr <*> sepEndBy pattern whiteSpace   loopPat :: Parser EgisonPattern-loopPat = keywordLoop >> LoopPat <$> varName <*> expr <*> pattern <*> option (NotPat WildCard) pattern+loopPat = keywordLoop >> LoopPat <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern++loopRange :: Parser LoopRange+loopRange = brackets ((try $ LoopRangeConstant <$> expr <*> expr)+                      <|> LoopRangeVariable  <$> expr <*> varName)  -- Constants 

@@ -103,10 +103,15 @@   | TuplePat [EgisonPattern]   | InductivePat String [EgisonPattern]   | ApplyPat EgisonExpr [EgisonPattern]-  | LoopPat String EgisonExpr EgisonPattern EgisonPattern+  | LoopPat String LoopRange EgisonPattern EgisonPattern   | ContPat  deriving (Show) +data LoopRange =+    LoopRangeConstant EgisonExpr EgisonExpr+  | LoopRangeVariable EgisonExpr String+ deriving (Show)+ data PrimitivePatPattern =     PPWildCard   | PPPatVar@@ -284,6 +289,10 @@ fromPrimitiveValue (Value val@(Float _)) = return val fromPrimitiveValue val = throwError $ TypeMismatch "primitive value" val  +extractInteger :: EgisonValue -> EgisonM Integer+extractInteger (Integer i) = return i+extractInteger val = throwError $ TypeMismatch "integer" (Value val)+ -- -- Environment --@@ -314,7 +323,9 @@  type PatternBinding = (Var, EgisonPattern) -data LoopContext = LoopContext Binding ObjectRef EgisonPattern EgisonPattern+data LoopContext =+    LoopContextConstant Binding Integer EgisonPattern EgisonPattern+  | LoopContextVariable Binding String EgisonPattern EgisonPattern  -- -- Errors

@@ -20,37 +20,33 @@         {[{@$xs $x} {[x xs]}]          [_ {}]}]        [<join ,$pxs $> [(list a)]-        {[$tgt (letrec {[$helper (lambda [$pxs $tgt]-                                   (match [pxs tgt] [(list a) (list a)]-                                     {[[<nil> _] {tgt}]-                                      [[<cons $x $xs> <cons ,x $ys>] (helper xs ys)]-                                      [[_ _] {}]}))]}-                 (helper pxs tgt))]}]+        {[$tgt (match-all [pxs tgt] [(list a) (list a)]+                 [[(loop $i [1 $n] <cons $xa_i ...> <nil>)+                   (loop $i [1 n] <cons ,xa_i ...> $rs)]+                  rs])]}]        [<join $ $> [(list a) (list a)]-        {[$tgt (letrec {[$helper (lambda [$xs $ys]-                                   (match ys (list a)-                                     {[<nil> {[xs {}]}]-                                      [<cons $z $zs> {[xs ys] @(helper {@xs z} zs)}]}))]}-                 (helper {} tgt))]}]+        {[$tgt (match-all tgt (list a)+                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]        [<nioj ,$pxs $> [(list a)]-        {[$tgt (letrec {[$helper (lambda [$pxs $tgt]-                                   (match [pxs tgt] [(list a) (list a)]-                                     {[[<nil> _] {tgt}]-                                      [[<snoc $x $xs> <snoc ,x $ys>] (helper xs ys)]-                                      [[_ _] {}]}))]}-                 (helper pxs tgt))]}]+        {[$tgt (match-all [pxs tgt] [(list a) (list a)]+                 [[(loop $i [1 $n] <snoc $xa_i ...> <nil>)+                   (loop $i [1 n] <snoc ,xa_i ...> $rs)]+                  rs])]}]        [<nioj $ $> [(list a) (list a)]-        {[$tgt (letrec {[$helper (lambda [$xs $ys]-                                   (match ys (list a)-                                     {[<nil> {[{} xs]}]-                                      [<cons $z $zs> {[ys xs] @(helper {@xs z} zs)}]}))]}-                 (helper {} tgt))]}]+        {[$tgt (match-all tgt (list a)+                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]        [$ [something]         {[$tgt {tgt}]}]        })))  (define $string (list char)) +(define $between+  (lambda [$s $e]+    (if (gt-i? s e)+        {}+        {s @(between (+ s 1) e)})))+ (define $map   (lambda [$fn $ls]     (match ls (list something)@@ -147,19 +143,6 @@            [<cons $x $ys> (let {[[$rs $i] (remove-and-count x ys)]}                             {[x i] @((occurrence a) rs)})]}))))) -#|-(define $subcollections-  (lambda [$xs]-    (foldr (lambda [$x $rs]-             (let {[[$y $i] x]} -               (map-and-concat (lambda [$sub] -                                 (match-all (index-loop $l $j (between 1 i) {y @l} {}) (list something)-                                   [<join $ys _> {@ys @sub}]))-                               rs)))-           {{}}-           ((occurrence a) xs))))-|#- (define $one-of   (lambda [$pred $xs]     (match xs (list something)@@ -169,11 +152,11 @@             #t             (one-of pred rs))]}))) -(define $size+(define $length   (lambda [$xs]     (match xs (list something)       {[<nil> 0]-       [<cons _ $rs> (+ 1 (size rs))]})))+       [<cons _ $rs> (+ 1 (length rs))]})))  (define $car   (lambda [$xs]@@ -271,7 +254,7 @@  (define $empty?   (match-lambda (list something)-   {[<nil>      #t]+   {[<nil> #t]     [<cons _ _> #f]}))  (define $multiset@@ -301,8 +284,7 @@ (define $set   (lambda [$a]     (matcher-      {-       [<nil> []+      {[<nil> []         {[{} {[]}]          [_ {}]}]        [<cons ,$px $> [(set a)]

@@ -1,7 +1,6 @@ (define $integer   (matcher-    {-     [,$n []+    {[,$n []       {[$tgt (if (eq? tgt n)                  {[]}                  {})]}]@@ -20,9 +19,7 @@ (define $float   (matcher     {[,$d []-      {[$tgt (if (eq? tgt d)-                 {[]}-                 {})]}]+      {[$tgt (if (eq? tgt d) {[]} {})]}]      [$ [something]       {[$tgt {tgt}]}]      }))@@ -38,9 +35,7 @@ (define $nat   (matcher     {[,$n []-      {[$tgt (if (eq? tgt n)-                 {[]}-                 {})]}]+      {[$tgt (if (eq? tgt n) {[]} {})]}]      [<o> []       {[0 {[]}]        [_ {}]}]@@ -99,11 +94,8 @@   (lambda [$ns]     (match ns (set integer)       {[<cons $n <nil>> n]-       [<cons (& ,(min ns) $m)-              $rs>-        (gcd {m @((remove-all integer)-                                       (map (lambda [$r] (mod r m))-                                            rs)+       [<cons (& ,(min ns) $m) $rs>+        (gcd {m @((remove-all integer) (map (lambda [$r] (mod r m)) rs)                                        0)})]})))  (define $fib

@@ -1,15 +0,0 @@-;;-;; Pattern.egi-;;--;(define $n-cons-;  (lambda [$n $v]-;    (loop $l $i (between 1 n) <cons $`v_i l> _)))--;(define $comb-;  (lambda [$n $v]-;    (loop $l $i (between 1 n) <join _ <cons $`v_i l>> _)))--;(define $comb/duplicate-;  (lambda [$n $v]-;    (loop $l $i (between 1 n) <join _ (& <cons $`v_i _> l)> _)))

@@ -13,42 +13,18 @@  (define $hamilton-cycle   (pattern-function [$a]-    (& $g-       <cons <node (& a_1 $h_1) <cons (& a_2 $h_2) _> _>-             (loop $i (between 3 (size g))-               <cons <node ,h_(- i 1) <cons (& a_i $h_i) _> _>-                     ...>-               <cons <node ,h_(size g) <cons ,h_1 _> _>-                     <nil>>)>)))+    <cons <node (& a_1 $h_1) <cons (& a_2 $h_2) _> _>+     (loop $i [3 $n]+       <cons <node ,h_(- i 1) <cons (& a_i $h_i) _> _>+             ...>+       <cons <node ,h_n <cons ,h_1 _> _>+             <nil>>)>))  (define $hamilton-path   (pattern-function [$a]-    (& $g-       <cons <node (& a_1 $h_1) <cons (& a_2 $h_2) _> _>-             (loop $i (between 3 (size g))-               <cons <node ,h_(- i 1) <cons (& a_i $h_i) _> _>-                     ...>-               <cons <node ,h_(size g) _ _>-                     <nil>>)>)))--(define $hamilton-path2-  (pattern-function [$a]-    (& $g-       (let {[$n (size g)]}-         <cons <node (& a_1 $h_1) <cons (& a_2 $h_2) _> _>-               (loop $i (between 3 n)-                 <cons <node ,h_(- i 1) <cons (& a_i $h_i) _> _>-                       ...>-                 <cons <node ,h_n _ _>-                       <nil>>)>)-       )))--(define $all-paths-  (pattern-function [$s $e $p $rest]-    (| <cons <node (& s p_1) <cons (& e p_2) _> _> rest>-       <cons <node (& s p_1)  <cons (& p_2 $h_2) _> _>-          (loop $i (from 2) ;; TEMPORARY-            <cons <node ,h_(- i 1) <cons (& p_i $h_i) _> _>-                  ...>-            rest)>)))-+    <cons <node (& a_1 $h_1) <cons (& a_2 $h_2) _> _>+     (loop $i [3 $n]+       <cons <node ,h_(- i 1) <cons (& a_i $h_i) _> _>+        ...>+       <cons <node ,h_n _ _>+        <nil>>)>))

@@ -0,0 +1,24 @@+(define $b-tree+  (lambda [$a]+    (algebraic-data-matcher+      {<leaf a> <node (b-tree a) (b-tree a)>})))++(define $n-tree+  (lambda [$a]+    (matcher+      {[,$val []+        {[$tgt (match [val tgt] [(n-tree a) (n-tree a)]+                 {[[<lnode $x $ts> <lnode ,x ,ts>] {[]}]+                  [[_ _] {}]})]}]+       [<lnode $ $> [a (list (n-tree a))] ; Node whose children are seen as a list.+        {[<Node $x $ts> {[x ts]}]+         [_ {}]}]+       [<mnode $ $> [a (multiset (n-tree a))] ; Node whose children are seen as a multiset.+        {[<Node $x $ts> {[x ts]}]+         [_ {}]}]+       [<descendant $> [(n-tree a)]+        {[$t {t @(match-all t (n-tree a)+                   [<mnode _ <cons <descendant $x> _>> x])}]}]+       [$ [something]+        {[$tgt {tgt}]}]+       })))