egison 3.0.4 → 3.0.5

raw patch · 8 files changed

+321/−280 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +1/−1
• elisp/egison-mode.el +3/−3
• hs-src/Interpreter/egisoni.hs +1/−1
• hs-src/Language/Egison.hs +33/−24
• hs-src/Language/Egison/Core.hs +54/−19
• hs-src/Language/Egison/Desugar.hs +0/−21
• hs-src/Language/Egison/Parser.hs +227/−210
• hs-src/Language/Egison/Types.hs +2/−1

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.0.4+Version:             3.0.5 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.

@@ -24,7 +24,7 @@      "\\<matcher\\>"      "\\<algebraic-data-matcher\\>"      "\\<loop\\>"-     "\\<function\\>"+     "\\<match-lambda\\>"      "\\<match\\>"      "\\<match-all\\>"      "\\<pattern-function\\>"@@ -33,7 +33,7 @@      "\\<undefined\\>"      "\\<something\\>"      -     "\\\."+     "\\\.\\\.\\\."      "\\\,"      "\\\!"      "`"@@ -116,7 +116,7 @@ (defun keyword-indent-point (name)   (cond ((equal "define" name) 2)         ((equal "lambda" name) 2)-        ((equal "function" name) 2)+        ((equal "match-lambda" name) 2)         ((equal "macro" name) 2)         ((equal "let" name) 2)         ((equal "letrec" name) 2)

@@ -110,7 +110,7 @@         Just "" ->  loop env prompt ""         Just input' -> do           let newInput = rest ++ input'-          result <- liftIO $ runEgisonTopExpr env newInput+          result <- liftIO $ runEgisonTopExprs env newInput           case result of             Left err | show err =~ "unexpected end of input" -> do               loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n"

@@ -3,13 +3,15 @@        ( module Language.Egison.Types        , module Language.Egison.Parser        , module Language.Egison.Primitives-       , counter --danger        , version+       , counter --danger        , loadLibraries        , loadPrimitives-       , runEgisonTopExpr+       , evalEgisonExpr        , evalEgisonTopExpr        , evalEgisonTopExprs+       , runEgisonTopExpr+       , runEgisonTopExprs        ) where  import Control.Applicative ((<$>), (<*>))@@ -26,18 +28,30 @@ import qualified Paths_egison as P  import Language.Egison.Types-import Language.Egison.Core import Language.Egison.Parser import Language.Egison.Primitives+import Language.Egison.Core +version :: Version+version = P.version+ -- Unsafe counter :: IORef Int counter = unsafePerformIO (newIORef 0) +readCounter :: IO Int+readCounter = readIORef counter -version :: Version-version = P.version+updateCounter :: Int -> IO ()+updateCounter = writeIORef counter +modifyCounter :: FreshT IO a -> IO a+modifyCounter m = do+  seed <- readCounter+  (result, seed) <- runFreshT seed m +  updateCounter seed+  return result  + loadLibraries :: Env -> IO Env loadLibraries env = do   seed <- readIORef counter@@ -58,26 +72,21 @@                  loadPrimitives :: Env -> IO Env loadPrimitives env = (++) <$> return env <*> primitiveEnv--runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env)-runEgisonTopExpr env input = do-  seed <- readIORef counter-  (result, seed') <- runFreshT seed $ runEgisonM $ do -    expr <- liftEgisonM $ readTopExpr input-    evalTopExpr env expr-  writeIORef counter seed'-  return result+  +evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue)+evalEgisonExpr env expr = modifyCounter $ runEgisonM $ evalExpr' env expr  evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env)-evalEgisonTopExpr env expr = do-  seed <- readIORef counter-  (result, seed') <- runFreshT seed $ runEgisonM $ evalTopExpr env expr-  writeIORef counter seed'-  return result+evalEgisonTopExpr env exprs = modifyCounter $ runEgisonM $ evalTopExpr env exprs  evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)-evalEgisonTopExprs env exprs = do-  seed <- readIORef counter-  (result, seed') <- runFreshT seed $ runEgisonM $ foldM evalTopExpr env exprs-  writeIORef counter seed'-  return result+evalEgisonTopExprs env exprs = modifyCounter $ runEgisonM $ evalTopExprs env exprs++runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env)+runEgisonTopExpr env input = modifyCounter $ runEgisonM $ liftEgisonM (readTopExpr input) >>= evalTopExpr env++runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env)+runEgisonTopExprs env input = modifyCounter $ runEgisonM $ liftEgisonM (readTopExprs input) >>= evalTopExprs env+++

@@ -36,13 +36,22 @@  evalTopExprs :: Env -> [EgisonTopExpr] -> EgisonM Env evalTopExprs env exprs = do-  let (bindings, rest) = foldr collectDefs ([], []) exprs+  (bindings, rest) <- collectDefs exprs [] []   env <- recursiveBind env bindings   forM_ rest $ evalTopExpr env   return env  where-  collectDefs (Define name expr) (bindings, rest) = ((name, expr) : bindings, rest)-  collectDefs expr (bindings, rest) = (bindings, expr : rest)  +  collectDefs (expr:exprs) bindings rest =+    case expr of+      Define name expr -> collectDefs exprs ((name, expr) : bindings) rest+      Load file -> do+        exprs' <- loadLibraryFile file+        collectDefs (exprs' ++ exprs) bindings rest+      LoadFile file -> do+        exprs' <- loadFile file+        collectDefs (exprs' ++ exprs) bindings rest+      _ -> collectDefs exprs bindings (expr : rest)+  collectDefs [] bindings rest = return (bindings, rest)  evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env evalTopExpr env (Define name expr) = recursiveBind env [(name, expr)]@@ -55,7 +64,7 @@   io <- applyFunc main $ Value $ Collection $ Sq.fromList $ map String argv   case io of     Value (IOFunc m) -> m >> return env-    _ -> throwError $ TypeMismatch "io" main+    _ -> throwError $ TypeMismatch "io" io evalTopExpr env (Load file) = loadLibraryFile file >>= evalTopExprs env evalTopExpr env (LoadFile file) = loadFile file >>= evalTopExprs env @@ -353,8 +362,31 @@   processMStates' (MCons state states) = (Nothing, [processMState state, states])  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+processMState state =+  if isNotPat state+    then do+      let (state1, state2) = splitMState state+      result <- processMStates [msingleton state1]+      case result of+        MNil -> return $ msingleton state2+        _ -> return MNil+    else processMState' state+ where+  isNotPat :: MatchingState -> Bool+  isNotPat (MState _ _ _ ((MAtom (NotPat _) _ _) : _)) = True+  isNotPat (MState _ _ _ ((MNode _ state) : _)) = isNotPat state+  isNotPat _ = False++  splitMState :: MatchingState -> (MatchingState, MatchingState)+  splitMState (MState env loops bindings ((MAtom (NotPat pattern) target matcher) : trees)) =+    (MState env loops bindings [MAtom pattern target matcher], MState env loops bindings trees)+  splitMState (MState env loops bindings ((MNode penv state) : trees)) =+    let (state1, state2) = splitMState state+    in (MState env loops bindings [MNode penv state1], MState env loops bindings (MNode penv state2 : trees)) ++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)   case pattern of     WildCard -> return $ msingleton $ MState env loops bindings trees @@ -363,9 +395,9 @@     ApplyPat func args -> do       func <- evalExpr env' func       case func of-        Value (PatternFunc env names expr) ->+        Value (PatternFunc env'' names expr) ->           let penv = zip names args-          in return $ msingleton $ MState env loops bindings (MNode penv (MState env [] [] [MAtom expr target matcher]) : trees)+          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@@ -397,11 +429,7 @@     OrPat patterns ->       return $ fromList $ flip map patterns $ \pattern ->         MState env loops bindings (MAtom pattern target matcher : trees)-    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-        _    -> return $ MNil+    NotPat pattern -> throwError $ strMsg "should not reach here (cut pattern)"     CutPat pattern -> -- TEMPORARY ignoring cut patterns       return $ msingleton (MState env loops bindings ((MAtom pattern target matcher):trees))     PredPat pred -> do@@ -410,13 +438,20 @@       result <- applyFunc func arg >>= liftError . fromBoolValue       if result then return $ msingleton $ (MState env loops bindings trees)                 else return MNil+    LetPat bindings' pattern ->+      let extractBindings ([name], expr) =+            makeBindings [name] . (:[]) <$> newThunk env' expr+          extractBindings (names, expr) =+            makeBindings names <$> (evalExpr env' expr >>= fromTuple)+      in+       liftM concat (mapM extractBindings bindings')+         >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern target matcher):trees))     _ ->       case matcher of         Value Something ->            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@@ -459,9 +494,9 @@             let trees' = zipWith3 MAtom patterns targets matchers ++ trees             return $ MState env loops bindings trees'         _ -> throwError $ TypeMismatch "matcher" matcher-processMState (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) =+processMState' (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) =   return $ msingleton $ MState env loops bindings trees-processMState (MState env loops bindings ((MNode penv state@(MState env' loops' bindings' (tree:trees')):trees))) = do+processMState' (MState env loops bindings ((MNode penv state@(MState env' loops' bindings' (tree:trees')):trees))) = do   case tree of     MAtom pattern target matcher -> do       case pattern of@@ -470,7 +505,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 -> -- TEMPORARY cannot use multiple indices+        IndexedPat (VarPat name) indices ->           case lookup name penv of             Just pattern -> do               let env'' = extendEnv env' (bindings' ++ map (\(LoopContext binding _ _ _) -> binding) loops')@@ -478,8 +513,8 @@               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)             Nothing -> throwError $ UnboundVariable name-        _ -> processMState state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv)-    _ -> processMState state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv)+        _ -> processMState' state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv)+    _ -> processMState' state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv)  inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher ->                   EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [WHNFData])

@@ -160,27 +160,6 @@   expr' <- desugar expr   return $ LetRecExpr binds' expr'   -{- temporarily commented-desugar (IndexLoopExpr n0 n1 n2 expr0 expr1 expr2 expr3) = do-  name <- fresh-  helper <- genHelper name-  return $ ApplyExpr (LetRecExpr [([name], helper)] (ApplyExpr (VarExpr name) expr1)) expr0- where-  genHelper :: String -> DesugarM EgisonExpr-  genHelper name = do-    indicesName <- fresh-    patName <- fresh-    let subst = [(n0, ApplyExpr (ApplyExpr (VarExpr name) (VarExpr indicesName)) (VarExpr patName)), (n1, VarExpr patName)]-    bodyExpr <- local (subst ++) $ desugar expr2-    initExpr <- desugar expr3-    let matchClauses = [ (PatternExpr $ InductivePattern "nil" [], LambdaExpr [patName] $ initExpr)-                       , (PatternExpr $ InductivePattern "cons" [PatternExpr (PatVar n2), PatternExpr (PatVar indicesName)], LambdaExpr [patName] $ bodyExpr)]-    return $ LambdaExpr [indicesName] $ MatchExpr (VarExpr indicesName) matcher matchClauses--  matcher :: EgisonExpr-  matcher = ApplyExpr (VarExpr "list") SomethingExpr--}-   desugar (MatchExpr expr0 expr1 clauses) = do     expr0' <- desugar expr0   expr1' <- desugar expr1

@@ -2,7 +2,11 @@        ( readTopExprs        , readTopExpr        , readExprs-       , readExpr ) where+       , readExpr +       , parseTopExprs+       , parseTopExpr+       , parseExprs+       , parseExpr ) where  import Control.Monad.Identity import Control.Monad.Error@@ -30,198 +34,207 @@ doParse p input = either (throwError . Parser) return $ parse p "egison" $ B.pack input  readTopExprs :: String -> Fresh (Either EgisonError [EgisonTopExpr])-readTopExprs input = runDesugarM $ either throwError (mapM desugarTopExpr) $ doParse (whiteSpace >> parseTopExprs) input+readTopExprs = runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs  readTopExpr :: String -> Fresh (Either EgisonError EgisonTopExpr)-readTopExpr input = runDesugarM $ either throwError desugarTopExpr $ doParse (whiteSpace >> parseTopExpr) input+readTopExpr = runDesugarM . either throwError desugarTopExpr . parseTopExpr  readExprs :: String -> Fresh (Either EgisonError [EgisonExpr])-readExprs input = runDesugarM $ either throwError (mapM desugar) $ doParse (whiteSpace >> parseExprs) input+readExprs = runDesugarM . either throwError (mapM desugar) . parseExprs  readExpr :: String -> Fresh (Either EgisonError EgisonExpr)-readExpr input = runDesugarM $ either throwError desugar $ doParse (whiteSpace >> parseExpr) input+readExpr = runDesugarM . either throwError desugar . parseExpr +parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]+parseTopExprs = doParse $ whiteSpace >> endBy topExpr whiteSpace++parseTopExpr :: String -> Either EgisonError EgisonTopExpr+parseTopExpr = doParse $ whiteSpace >> topExpr++parseExprs :: String -> Either EgisonError [EgisonExpr]+parseExprs = doParse $ whiteSpace >> endBy expr whiteSpace++parseExpr :: String -> Either EgisonError EgisonExpr+parseExpr = doParse $ whiteSpace >> expr+ -- -- Expressions -- -parseTopExprs :: Parser [EgisonTopExpr]-parseTopExprs = endBy parseTopExpr whiteSpace--parseTopExpr :: Parser EgisonTopExpr-parseTopExpr = parens (parseDefineExpr-                       <|> parseTestExpr-                       <|> parseExecuteExpr-                       <|> parseLoadFileExpr-                       <|> parseLoadExpr-                       <?> "top-level expression")+topExpr :: Parser EgisonTopExpr+topExpr = parens (defineExpr+                  <|> testExpr+                  <|> executeExpr+                  <|> loadFileExpr+                  <|> loadExpr+                  <?> "top-level expression") -parseDefineExpr :: Parser EgisonTopExpr-parseDefineExpr = keywordDefine >> Define <$> parseVarName <*> parseExpr+defineExpr :: Parser EgisonTopExpr+defineExpr = keywordDefine >> Define <$> varName <*> expr -parseTestExpr :: Parser EgisonTopExpr-parseTestExpr = keywordTest >> Test <$> parseExpr+testExpr :: Parser EgisonTopExpr+testExpr = keywordTest >> Test <$> expr -parseExecuteExpr :: Parser EgisonTopExpr-parseExecuteExpr = keywordExecute >> Execute <$> sepEndBy stringLiteral whiteSpace+executeExpr :: Parser EgisonTopExpr+executeExpr = keywordExecute >> Execute <$> sepEndBy stringLiteral whiteSpace -parseLoadFileExpr :: Parser EgisonTopExpr-parseLoadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral+loadFileExpr :: Parser EgisonTopExpr+loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral -parseLoadExpr :: Parser EgisonTopExpr-parseLoadExpr = keywordLoad >> Load <$> stringLiteral+loadExpr :: Parser EgisonTopExpr+loadExpr = keywordLoad >> Load <$> stringLiteral -parseExprs :: Parser [EgisonExpr]-parseExprs = endBy parseExpr whiteSpace+exprs :: Parser [EgisonExpr]+exprs = endBy expr whiteSpace -parseExpr :: Parser EgisonExpr-parseExpr = do expr <- parseExpr'-               option expr $ IndexedExpr expr <$> many1 (try $ char '_' >> parseExpr')+expr :: Parser EgisonExpr+expr = do expr <- expr'+          option expr $ IndexedExpr expr <$> many1 (try $ char '_' >> expr') -parseExpr' :: Parser EgisonExpr-parseExpr' = (try parseConstantExpr-             <|> try parseVarExpr-             <|> parseInductiveDataExpr-             <|> try parseArrayExpr-             <|> parseTupleExpr-             <|> parseCollectionExpr-             <|> parens (parseIfExpr-                         <|> parseLambdaExpr-                         <|> parsePatternFunctionExpr-                         <|> parseLetRecExpr-                         <|> parseLetExpr-                         <|> parseDoExpr-                         <|> parseMatchAllExpr-                         <|> parseMatchExpr-                         <|> parseMatcherExpr-                         <|> parseMatchLambdaExpr-                         <|> parseApplyExpr-                         <|> parseAlgebraicDataMatcherExpr-                         <|> parseGenerateArrayExpr-                         <|> parseArraySizeExpr-                         <|> parseArrayRefExpr)+expr' :: Parser EgisonExpr+expr' = (try constantExpr+             <|> try varExpr+             <|> inductiveDataExpr+             <|> try arrayExpr+             <|> tupleExpr+             <|> collectionExpr+             <|> parens (ifExpr+                         <|> lambdaExpr+                         <|> patternFunctionExpr+                         <|> letRecExpr+                         <|> letExpr+                         <|> doExpr+                         <|> matchAllExpr+                         <|> matchExpr+                         <|> matcherExpr+                         <|> matchLambdaExpr+                         <|> applyExpr+                         <|> algebraicDataMatcherExpr+                         <|> generateArrayExpr+                         <|> arraySizeExpr+                         <|> arrayRefExpr)                          <?> "expression") -parseVarExpr :: Parser EgisonExpr-parseVarExpr = VarExpr <$> ident+varExpr :: Parser EgisonExpr+varExpr = VarExpr <$> ident -parseInductiveDataExpr :: Parser EgisonExpr-parseInductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy parseExpr whiteSpace+inductiveDataExpr :: Parser EgisonExpr+inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace -parseTupleExpr :: Parser EgisonExpr-parseTupleExpr = brackets $ TupleExpr <$> sepEndBy parseExpr whiteSpace+tupleExpr :: Parser EgisonExpr+tupleExpr = brackets $ TupleExpr <$> sepEndBy expr whiteSpace -parseCollectionExpr :: Parser EgisonExpr-parseCollectionExpr = braces $ CollectionExpr . Sq.fromList <$> sepEndBy parseInnerExpr whiteSpace+collectionExpr :: Parser EgisonExpr+collectionExpr = braces $ CollectionExpr . Sq.fromList <$> sepEndBy innerExpr whiteSpace  where-  parseInnerExpr :: Parser InnerExpr-  parseInnerExpr = (char '@' >> SubCollectionExpr <$> parseExpr)-               <|> ElementExpr <$> parseExpr+  innerExpr :: Parser InnerExpr+  innerExpr = (char '@' >> SubCollectionExpr <$> expr)+               <|> ElementExpr <$> expr -parseArrayExpr :: Parser EgisonExpr-parseArrayExpr = between lp rp $ ArrayExpr <$> sepEndBy parseExpr whiteSpace+arrayExpr :: Parser EgisonExpr+arrayExpr = between lp rp $ ArrayExpr <$> sepEndBy expr whiteSpace   where     lp = P.lexeme lexer (string "[|")     rp = P.lexeme lexer (string "|]") -parseMatchAllExpr :: Parser EgisonExpr-parseMatchAllExpr = keywordMatchAll >> MatchAllExpr <$> parseExpr <*> parseExpr <*> parseMatchClause+matchAllExpr :: Parser EgisonExpr+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> matchClause -parseMatchExpr :: Parser EgisonExpr-parseMatchExpr = keywordMatch >> MatchExpr <$> parseExpr <*> parseExpr <*> parseMatchClauses+matchExpr :: Parser EgisonExpr+matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses -parseMatchLambdaExpr :: Parser EgisonExpr-parseMatchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> parseExpr <*> parseMatchClauses+matchLambdaExpr :: Parser EgisonExpr+matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses -parseMatchClauses :: Parser [MatchClause]-parseMatchClauses = braces $ sepEndBy parseMatchClause whiteSpace+matchClauses :: Parser [MatchClause]+matchClauses = braces $ sepEndBy matchClause whiteSpace -parseMatchClause :: Parser MatchClause-parseMatchClause = brackets $ (,) <$> parsePattern <*> parseExpr+matchClause :: Parser MatchClause+matchClause = brackets $ (,) <$> pattern <*> expr -parseMatcherExpr :: Parser EgisonExpr-parseMatcherExpr = keywordMatcher >> MatcherExpr <$> parsePPMatchClauses+matcherExpr :: Parser EgisonExpr+matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses -parsePPMatchClauses :: Parser MatcherInfo-parsePPMatchClauses = braces $ sepEndBy parsePPMatchClause whiteSpace+ppMatchClauses :: Parser MatcherInfo+ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace -parsePPMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])-parsePPMatchClause = brackets $ (,,) <$> parsePPPattern <*> parseExpr <*> parsePDMatchClauses+ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+ppMatchClause = brackets $ (,,) <$> pppattern <*> expr <*> pdMatchClauses -parsePDMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]-parsePDMatchClauses = braces $ sepEndBy parsePDMatchClause whiteSpace+pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]+pdMatchClauses = braces $ sepEndBy pdMatchClause whiteSpace -parsePDMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr)-parsePDMatchClause = brackets $ (,) <$> parsePDPattern <*> parseExpr+pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr)+pdMatchClause = brackets $ (,) <$> pdPattern <*> expr -parsePPPattern :: Parser PrimitivePatPattern-parsePPPattern = parsePPWildCard-                 <|> parsePPPatVar-                 <|> parsePPValuePat-                 <|> parsePPInductivePat+pppattern :: Parser PrimitivePatPattern+pppattern = ppWildCard+                 <|> pppatVar+                 <|> ppValuePat+                 <|> ppInductivePat                  <?> "primitive-pattren-pattern"                        -parsePPWildCard :: Parser PrimitivePatPattern-parsePPWildCard = reservedOp "_" *> pure PPWildCard+ppWildCard :: Parser PrimitivePatPattern+ppWildCard = reservedOp "_" *> pure PPWildCard -parsePPPatVar :: Parser PrimitivePatPattern-parsePPPatVar = reservedOp "$" *> pure PPPatVar+pppatVar :: Parser PrimitivePatPattern+pppatVar = reservedOp "$" *> pure PPPatVar -parsePPValuePat :: Parser PrimitivePatPattern-parsePPValuePat = string ",$" >> PPValuePat <$> ident+ppValuePat :: Parser PrimitivePatPattern+ppValuePat = string ",$" >> PPValuePat <$> ident -parsePPInductivePat :: Parser PrimitivePatPattern-parsePPInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy parsePPPattern whiteSpace)+ppInductivePat :: Parser PrimitivePatPattern+ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy pppattern whiteSpace) -parsePDPattern :: Parser PrimitiveDataPattern-parsePDPattern = reservedOp "_" *> pure PDWildCard+pdPattern :: Parser PrimitiveDataPattern+pdPattern = reservedOp "_" *> pure PDWildCard                     <|> (char '$' >> PDPatVar <$> ident)-                    <|> braces ((PDConsPat <$> parsePDPattern <*> (char '@' *> parsePDPattern))-                            <|> (PDSnocPat <$> (char '@' *> parsePDPattern) <*> parsePDPattern) +                    <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern))+                            <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern)                              <|> pure PDEmptyPat)-                    <|> angles (PDInductivePat <$> upperName <*> sepEndBy parsePDPattern whiteSpace)-                    <|> PDConstantPat <$> parseConstantExpr+                    <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace)+                    <|> PDConstantPat <$> constantExpr                     <?> "primitive-data-pattern" -parseIfExpr :: Parser EgisonExpr-parseIfExpr = keywordIf >> IfExpr <$> parseExpr <*> parseExpr <*> parseExpr+ifExpr :: Parser EgisonExpr+ifExpr = keywordIf >> IfExpr <$> expr <*> expr <*> expr -parseLambdaExpr :: Parser EgisonExpr-parseLambdaExpr = keywordLambda >> LambdaExpr <$> parseVarNames <*> parseExpr+lambdaExpr :: Parser EgisonExpr+lambdaExpr = keywordLambda >> LambdaExpr <$> varNames <*> expr -parsePatternFunctionExpr :: Parser EgisonExpr-parsePatternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> parseVarNames <*> parsePattern+patternFunctionExpr :: Parser EgisonExpr+patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern -parseLetRecExpr :: Parser EgisonExpr-parseLetRecExpr =  keywordLetRec >> LetRecExpr <$> parseBindings <*> parseExpr+letRecExpr :: Parser EgisonExpr+letRecExpr =  keywordLetRec >> LetRecExpr <$> bindings <*> expr -parseLetExpr :: Parser EgisonExpr-parseLetExpr = keywordLet >> LetExpr <$> parseBindings <*> parseExpr+letExpr :: Parser EgisonExpr+letExpr = keywordLet >> LetExpr <$> bindings <*> expr -parseDoExpr :: Parser EgisonExpr-parseDoExpr = keywordDo >> DoExpr <$> parseBindings <*> parseExpr+doExpr :: Parser EgisonExpr+doExpr = keywordDo >> DoExpr <$> bindings <*> expr -parseBindings :: Parser [BindingExpr]-parseBindings = braces $ sepEndBy parseBinding whiteSpace+bindings :: Parser [BindingExpr]+bindings = braces $ sepEndBy binding whiteSpace -parseBinding :: Parser BindingExpr-parseBinding = brackets $ (,) <$> parseVarNames <*> parseExpr+binding :: Parser BindingExpr+binding = brackets $ (,) <$> varNames <*> expr -parseVarNames :: Parser [String]-parseVarNames = return <$> parseVarName-            <|> brackets (sepEndBy parseVarName whiteSpace) +varNames :: Parser [String]+varNames = return <$> varName+            <|> brackets (sepEndBy varName whiteSpace)  -parseVarName :: Parser String-parseVarName = char '$' >> ident+varName :: Parser String+varName = char '$' >> ident -parseApplyExpr :: Parser EgisonExpr-parseApplyExpr = (keywordApply >> ApplyExpr <$> parseExpr <*> parseExpr) -             <|> parseApplyExpr'+applyExpr :: Parser EgisonExpr+applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr) +             <|> applyExpr' -parseApplyExpr' :: Parser EgisonExpr-parseApplyExpr' = do-  func <- parseExpr-  args <- parseArgs+applyExpr' :: Parser EgisonExpr+applyExpr' = do+  func <- expr+  args <- args   let vars = lefts args   case vars of     [] -> return . ApplyExpr func . TupleExpr $ rights args@@ -239,118 +252,122 @@              else fail "invalid partial application"       | otherwise -> fail "invalid partial application"  where-  parseArgs = sepEndBy parseArg whiteSpace-  parseArg = try (Right <$> parseExpr)-         <|> char '$' *> (Left <$> option "" parseIndex)-  parseIndex = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit+  args = sepEndBy arg whiteSpace+  arg = try (Right <$> expr)+         <|> char '$' *> (Left <$> option "" index)+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit   annonVars n = take n $ map (('#':) . show) [1..] -parseAlgebraicDataMatcherExpr :: Parser EgisonExpr-parseAlgebraicDataMatcherExpr = keywordAlgebraicDataMatcher-                                >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 parseInductivePat' whiteSpace)+algebraicDataMatcherExpr :: Parser EgisonExpr+algebraicDataMatcherExpr = keywordAlgebraicDataMatcher+                                >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace)   where-    parseInductivePat' :: Parser (String, [EgisonExpr]) -    parseInductivePat' = angles $ (,) <$> lowerName <*> sepEndBy parseExpr whiteSpace+    inductivePat' :: Parser (String, [EgisonExpr]) +    inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace -parseGenerateArrayExpr :: Parser EgisonExpr-parseGenerateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> parseVarNames <*> parseExpr <*> parseExpr+generateArrayExpr :: Parser EgisonExpr+generateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> varNames <*> expr <*> expr -parseArraySizeExpr :: Parser EgisonExpr-parseArraySizeExpr = keywordArraySize >> ArraySizeExpr <$> parseExpr+arraySizeExpr :: Parser EgisonExpr+arraySizeExpr = keywordArraySize >> ArraySizeExpr <$> expr -parseArrayRefExpr :: Parser EgisonExpr-parseArrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> parseExpr <*> parseExpr+arrayRefExpr :: Parser EgisonExpr+arrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> expr <*> expr  -- Patterns -parsePattern :: Parser EgisonPattern-parsePattern = do pattern <- parsePattern'-                  option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> parseExpr')+pattern :: Parser EgisonPattern+pattern = do pattern <- pattern'+             option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> expr') -parsePattern' :: Parser EgisonPattern-parsePattern' = parseWildCard-            <|> parsePatVar-            <|> parseVarPat-            <|> parseValuePat-            <|> parsePredPat-            <|> parseCutPat-            <|> parseNotPat-            <|> parseTuplePat-            <|> parseInductivePat-            <|> parseContPat-            <|> parens (parseAndPat-                    <|> parseOrPat-                    <|> parseApplyPat-                    <|> parseLoopPat)+pattern' :: Parser EgisonPattern+pattern' = wildCard+            <|> patVar+            <|> varPat+            <|> valuePat+            <|> predPat+            <|> cutPat+            <|> notPat+            <|> tuplePat+            <|> inductivePat+            <|> contPat+            <|> parens (andPat+                    <|> orPat+                    <|> applyPat+                    <|> loopPat+                    <|> letPat) -parseWildCard :: Parser EgisonPattern-parseWildCard = reservedOp "_" >> pure WildCard+wildCard :: Parser EgisonPattern+wildCard = reservedOp "_" >> pure WildCard -parsePatVar :: Parser EgisonPattern-parsePatVar = P.lexeme lexer $ PatVar <$> parseVarName+patVar :: Parser EgisonPattern+patVar = P.lexeme lexer $ PatVar <$> varName -parseVarPat :: Parser EgisonPattern-parseVarPat = VarPat <$> ident+varPat :: Parser EgisonPattern+varPat = VarPat <$> ident -parseValuePat :: Parser EgisonPattern-parseValuePat = reservedOp "," >> ValuePat <$> parseExpr+valuePat :: Parser EgisonPattern+valuePat = reservedOp "," >> ValuePat <$> expr -parsePredPat :: Parser EgisonPattern-parsePredPat = reservedOp "?" >> PredPat <$> parseExpr+predPat :: Parser EgisonPattern+predPat = reservedOp "?" >> PredPat <$> expr -parseCutPat :: Parser EgisonPattern-parseCutPat = reservedOp "!" >> CutPat <$> parsePattern+letPat :: Parser EgisonPattern+letPat = keywordLet >> LetPat <$> bindings <*> pattern -parseNotPat :: Parser EgisonPattern-parseNotPat = reservedOp "^" >> NotPat <$> parsePattern+cutPat :: Parser EgisonPattern+cutPat = reservedOp "!" >> CutPat <$> pattern -parseTuplePat :: Parser EgisonPattern-parseTuplePat = brackets $ TuplePat <$> sepEndBy parsePattern whiteSpace+notPat :: Parser EgisonPattern+notPat = reservedOp "^" >> NotPat <$> pattern -parseInductivePat :: Parser EgisonPattern-parseInductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy parsePattern whiteSpace+tuplePat :: Parser EgisonPattern+tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace -parseContPat :: Parser EgisonPattern-parseContPat = reservedOp "..." >> pure ContPat+inductivePat :: Parser EgisonPattern+inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace -parseAndPat :: Parser EgisonPattern-parseAndPat = reservedOp "&" >> AndPat <$> sepEndBy parsePattern whiteSpace+contPat :: Parser EgisonPattern+contPat = reservedOp "..." >> pure ContPat -parseOrPat :: Parser EgisonPattern-parseOrPat = reservedOp "|" >> OrPat <$> sepEndBy parsePattern whiteSpace+andPat :: Parser EgisonPattern+andPat = reservedOp "&" >> AndPat <$> sepEndBy pattern whiteSpace -parseApplyPat :: Parser EgisonPattern-parseApplyPat = ApplyPat <$> parseExpr <*> sepEndBy parsePattern whiteSpace +orPat :: Parser EgisonPattern+orPat = reservedOp "|" >> OrPat <$> sepEndBy pattern whiteSpace -parseLoopPat :: Parser EgisonPattern-parseLoopPat = keywordLoop >> LoopPat <$> parseVarName <*> parseExpr <*> parsePattern <*> parsePattern+applyPat :: Parser EgisonPattern+applyPat = ApplyPat <$> expr <*> sepEndBy pattern whiteSpace  +loopPat :: Parser EgisonPattern+loopPat = keywordLoop >> LoopPat <$> varName <*> expr <*> pattern <*> option (NotPat WildCard) pattern+ -- Constants -parseConstantExpr :: Parser EgisonExpr-parseConstantExpr =  parseCharExpr-                 <|> parseStringExpr-                 <|> parseBoolExpr-                 <|> try parseFloatExpr-                 <|> parseIntegerExpr+constantExpr :: Parser EgisonExpr+constantExpr =  charExpr+                 <|> stringExpr+                 <|> boolExpr+                 <|> try floatExpr+                 <|> integerExpr                  <|> (keywordSomething *> pure SomethingExpr)                  <|> (keywordUndefined *> pure UndefinedExpr)                  <?> "constant" -parseCharExpr :: Parser EgisonExpr-parseCharExpr = CharExpr <$> charLiteral+charExpr :: Parser EgisonExpr+charExpr = CharExpr <$> charLiteral -parseStringExpr :: Parser EgisonExpr-parseStringExpr = StringExpr <$> stringLiteral+stringExpr :: Parser EgisonExpr+stringExpr = StringExpr <$> stringLiteral -parseBoolExpr :: Parser EgisonExpr-parseBoolExpr = BoolExpr <$> boolLiteral+boolExpr :: Parser EgisonExpr+boolExpr = BoolExpr <$> boolLiteral -parseIntegerExpr :: Parser EgisonExpr-parseIntegerExpr = IntegerExpr <$> integerLiteral+integerExpr :: Parser EgisonExpr+integerExpr = IntegerExpr <$> integerLiteral -parseFloatExpr :: Parser EgisonExpr-parseFloatExpr = FloatExpr <$> floatLiteral+floatExpr :: Parser EgisonExpr+floatExpr = FloatExpr <$> floatLiteral  -- -- Tokens@@ -386,7 +403,7 @@   , "if"   , "apply"   , "lambda"-  , "pattern-constructor"+  , "pattern-function"   , "letrec"   , "let"   , "loop"

@@ -87,6 +87,7 @@   | ValuePat EgisonExpr   | PredPat EgisonExpr   | IndexedPat EgisonPattern [EgisonExpr]+  | LetPat [BindingExpr] EgisonPattern   | CutPat EgisonPattern   | NotPat EgisonPattern   | AndPat [EgisonPattern]@@ -280,7 +281,7 @@  type PatternBinding = (Var, EgisonPattern) -data LoopContext = LoopContext (String, ObjectRef) ObjectRef EgisonPattern EgisonPattern+data LoopContext = LoopContext Binding ObjectRef EgisonPattern EgisonPattern  -- -- Errors