diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.7.14 +Version: 3.8.0 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language. diff --git a/hs-src/Interpreter/egison.hs b/hs-src/Interpreter/egison.hs --- a/hs-src/Interpreter/egison.hs +++ b/hs-src/Interpreter/egison.hs @@ -1,26 +1,32 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + module Main where -import Prelude hiding (catch) -import Control.Exception ( AsyncException(..), catch ) -import Control.Monad.Except +import Control.Exception (AsyncException (..), catch) +import Control.Monad.Except +import Control.Monad.Trans.State +import Prelude hiding (catch) -import qualified Data.Text as T -import Data.Char -import Data.List (intercalate) +import Data.Char +import Data.List (intercalate) +import qualified Data.Text as T -import Data.Version +import Data.Version -import System.Environment -import System.Directory (getHomeDirectory) -import System.FilePath (()) -import System.Console.Haskeline hiding (handle, catch, throwTo) -import System.Console.GetOpt -import System.Exit (ExitCode (..), exitWith, exitFailure) -import System.IO +import System.Console.GetOpt +import System.Console.Haskeline hiding (catch, handle, throwTo) +import System.Directory (getHomeDirectory) +import System.Environment +import System.Exit (ExitCode (..), exitFailure, + exitSuccess) +import System.FilePath (()) +import System.IO -import Language.Egison -import Language.Egison.Util -import Language.Egison.MathOutput +import Language.Egison +import Language.Egison.Core (recursiveBind) +import Language.Egison.MathOutput +import Language.Egison.Util main :: IO () main = do args <- getArgs @@ -31,36 +37,36 @@ Options {optShowVersion = True} -> printVersionNumber Options {optEvalString = mExpr, optExecuteString = mCmd, optSubstituteString = mSub, optFieldInfo = fieldInfo, optLoadLibs = loadLibs, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optTsvOutput = tsvFlag, optNoIO = noIOFlag, optMathExpr = mathExprLang, optSExpr = isSExpr} -> do coreEnv <- if noIOFlag then initialEnvNoIO else initialEnv - mEnv <- evalEgisonTopExprs coreEnv $ (map (Load isSExpr) loadLibs) ++ (map (LoadFile isSExpr) loadFiles) + mEnv <- evalEgisonTopExprs coreEnv $ map (Load isSExpr) loadLibs ++ map (LoadFile isSExpr) loadFiles case mEnv of - Left err -> putStrLn $ show err - Right env -> do + Left err -> print err + Right env -> case mExpr of Just expr -> if tsvFlag - then do ret <- runEgisonTopExprs isSExpr env ("(execute (each (compose show-tsv print) " ++ expr ++ "))") + then do ret <- runEgisonTopExprs isSExpr env $ "(execute (each (compose show-tsv print) " ++ expr ++ "))" case ret of - Left err -> hPutStrLn stderr $ show err - Right _ -> return () + Left err -> hPrint stderr err + Right _ -> return () else do ret <- runEgisonExpr isSExpr env expr case ret of - Left err -> hPutStrLn stderr (show err) >> exitFailure - Right val -> putStrLn (show val) >> exitWith ExitSuccess + Left err -> hPrint stderr err >> exitFailure + Right val -> print val >> exitSuccess Nothing -> case mCmd of Just cmd -> do cmdRet <- runEgisonTopExpr isSExpr env ("(execute " ++ cmd ++ ")") case cmdRet of - Left err -> putStrLn (show err) >> exitFailure - _ -> exitWith ExitSuccess + Left err -> print err >> exitFailure + _ -> exitSuccess Nothing -> case mSub of - Just sub -> do cmdRet <- runEgisonTopExprs isSExpr env ("(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if tsvFlag then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ intercalate " " (map fst fieldInfo) ++ "} {" ++ intercalate " " (map snd fieldInfo) ++ "})]} (" ++ sub ++ " SH.input))))") + Just sub -> do cmdRet <- runEgisonTopExprs isSExpr env ("(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if tsvFlag then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ unwords (map fst fieldInfo) ++ "} {" ++ unwords (map snd fieldInfo) ++ "})]} (" ++ sub ++ " SH.input))))") case cmdRet of - Left err -> putStrLn (show err) >> exitFailure - _ -> exitWith ExitSuccess + Left err -> print err >> exitFailure + _ -> exitSuccess Nothing -> case nonOpts of - [] -> when bannerFlag showBanner >> repl noIOFlag isSExpr mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitWith ExitSuccess + [] -> when bannerFlag showBanner >> repl noIOFlag isSExpr mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitSuccess (file:args) -> case opts of Options {optTestOnly = True} -> do @@ -70,25 +76,25 @@ else evalEgisonTopExprsTestOnly env [LoadFile isSExpr file] either print (const $ return ()) result Options {optTestOnly = False} -> do - result <- evalEgisonTopExprs env [LoadFile isSExpr file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map (ElementExpr . StringExpr) (map T.pack args))))] + result <- evalEgisonTopExprs env [LoadFile isSExpr file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map ((ElementExpr . StringExpr) . T.pack) args)))] either print (const $ return ()) result data Options = Options { - optShowVersion :: Bool, - optShowHelp :: Bool, - optEvalString :: Maybe String, - optExecuteString :: Maybe String, + optShowVersion :: Bool, + optShowHelp :: Bool, + optEvalString :: Maybe String, + optExecuteString :: Maybe String, optSubstituteString :: Maybe String, - optFieldInfo :: [(String, String)], - optLoadLibs :: [String], - optLoadFiles :: [String], - optTsvOutput :: Bool, - optNoIO :: Bool, - optShowBanner :: Bool, - optTestOnly :: Bool, - optPrompt :: String, - optMathExpr :: Maybe String, - optSExpr :: Bool + optFieldInfo :: [(String, String)], + optLoadLibs :: [String], + optLoadFiles :: [String], + optTsvOutput :: Bool, + optNoIO :: Bool, + optShowBanner :: Bool, + optTestOnly :: Bool, + optPrompt :: String, + optMathExpr :: Maybe String, + optSExpr :: Bool } defaultOptions :: Options @@ -163,13 +169,13 @@ (NoArg (\opts -> opts {optTsvOutput = True})) "output in tsv format", Option ['F'] ["--field"] - (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [(readFieldOption d)]}) + (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [readFieldOption d]}) "String") "field information", Option ['M'] ["math"] (ReqArg (\lang opts -> opts {optMathExpr = Just lang}) "String") - "output in AsciiMath, Latex, or Mathematica format", + "output in AsciiMath, Latex, Mathematica, or Maxima format", Option ['N'] ["new-syntax"] (NoArg (\opts -> opts {optSExpr = False})) "parse by new syntax" @@ -222,14 +228,14 @@ putStrLn "Options to change input or output format:" putStrLn " --tsv, -T Input and output in tsv format" putStrLn " --field, -F field Specify a field type of input tsv" - putStrLn " --math, -M (asciimath|latex|mathematica)" + putStrLn " --math, -M (asciimath|latex|mathematica|maxima)" putStrLn " Output in AsciiMath, LaTeX, or Mathematica format (only for interpreter)" - exitWith ExitSuccess + exitSuccess printVersionNumber :: IO () printVersionNumber = do putStrLn $ showVersion version - exitWith ExitSuccess + exitSuccess showBanner :: IO () showBanner = do @@ -242,47 +248,48 @@ -- putStrLn $ "*****************" showByebyeMessage :: IO () -showByebyeMessage = putStrLn $ "Leaving Egison Interpreter." +showByebyeMessage = putStrLn "Leaving Egison Interpreter." -repl :: Bool -> Bool -> (Maybe String) -> Env -> String -> IO () -repl noIOFlag isSExpr mathExprLang env prompt = do - loop env +repl :: Bool -> Bool -> Maybe String -> Env -> String -> IO () +repl noIOFlag isSExpr mathExprLang env prompt = + loop $ StateT (\defines -> (, defines) <$> recursiveBind env defines) where settings :: MonadIO m => FilePath -> Settings m settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home ".egison_history") } - loop :: Env -> IO () - loop env = (do + loop :: StateT [(Var, EgisonExpr)] EgisonM Env -> IO () + loop st = (do home <- getHomeDirectory input <- liftIO $ runInputT (settings home) $ getEgisonExpr isSExpr prompt case (noIOFlag, input) of (_, Nothing) -> return () - (True, Just (_, (LoadFile _ _))) -> do + (True, Just (_, LoadFile _ _)) -> do putStrLn "error: No IO support" - loop env - (True, Just (_, (Load _ _))) -> do + loop st + (True, Just (_, Load _ _)) -> do putStrLn "error: No IO support" - loop env + loop st (_, Just (topExpr, _)) -> do - result <- liftIO $ runEgisonTopExpr' isSExpr env topExpr + result <- liftIO $ runEgisonTopExpr' isSExpr st topExpr case result of Left err -> do - liftIO $ putStrLn $ show err - loop env - Right (Nothing, env') -> loop env' - Right (Just output, env') -> + liftIO $ print err + loop st + Right (Nothing, st') -> loop st' + Right (Just output, st') -> case mathExprLang of - Nothing -> putStrLn output >> loop env' - (Just "haskell") -> putStrLn (mathExprToHaskell output) >> loop env' - (Just "asciimath") -> putStrLn (mathExprToAsciiMath output) >> loop env' - (Just "latex") -> putStrLn (mathExprToLatex output) >> loop env' - (Just "mathematica") -> putStrLn (mathExprToMathematica output) >> loop env' + Nothing -> putStrLn output >> loop st' + (Just "haskell") -> putStrLn (mathExprToHaskell output) >> loop st' + (Just "asciimath") -> putStrLn (mathExprToAsciiMath output) >> loop st' + (Just "latex") -> putStrLn (mathExprToLatex output) >> loop st' + (Just "mathematica") -> putStrLn (mathExprToMathematica output) >> loop st' + (Just "maxima") -> putStrLn (mathExprToMaxima output) >> loop st' _ -> putStrLn "error: this output lang is not supported" ) `catch` - (\e -> case e of - UserInterrupt -> putStrLn "" >> loop env - StackOverflow -> putStrLn "Stack over flow!" >> loop env - HeapOverflow -> putStrLn "Heap over flow!" >> loop env - _ -> putStrLn "error!" >> loop env + (\case + UserInterrupt -> putStrLn "" >> loop st + StackOverflow -> putStrLn "Stack over flow!" >> loop st + HeapOverflow -> putStrLn "Heap over flow!" >> loop st + _ -> putStrLn "error!" >> loop st ) diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -29,15 +29,17 @@ , version ) where -import Data.Version -import qualified Paths_egison as P +import Data.Version +import qualified Paths_egison as P -import Language.Egison.Types -import Language.Egison.Parser as Parser -import Language.Egison.ParserNonS as ParserNonS -import Language.Egison.Primitives -import Language.Egison.Core +import Language.Egison.Core +import Language.Egison.Parser as Parser +import Language.Egison.ParserNonS as ParserNonS +import Language.Egison.Primitives +import Language.Egison.Types +import Control.Monad.State + -- |Version number version :: Version version = P.version @@ -69,9 +71,9 @@ runEgisonTopExpr False env input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr env -- |eval an Egison top expression. Input is a Haskell string. -runEgisonTopExpr' :: Bool -> Env -> String -> IO (Either EgisonError (Maybe String, Env)) -runEgisonTopExpr' True env input = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' env -runEgisonTopExpr' False env input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' env +runEgisonTopExpr' :: Bool -> StateT [(Var, EgisonExpr)] EgisonM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env)) +runEgisonTopExpr' True st input = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' st +runEgisonTopExpr' False st input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' st -- |eval Egison top expressions. Input is a Haskell string. runEgisonTopExprs :: Bool -> Env -> String -> IO (Either EgisonError Env) 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} @@ -42,38 +43,41 @@ , packStringValue ) where -import Prelude hiding (mapM, mappend, mconcat) +import Prelude hiding (mapM, mappend, mconcat) import Control.Applicative import Control.Arrow -import Control.Lens (makeLenses, (%~), (&), (.~), (^.)) -import Control.Monad.Except hiding (mapM) -import Control.Monad.State hiding (mapM, state) +import Control.Lens (makeLenses, (%~), (&), (.~), (^.)) +import Control.Monad (when) +import Control.Monad.Except hiding (mapM) +import Control.Monad.State hiding (mapM) import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State (evalStateT, withStateT) -import Data.Foldable (toList) +import Data.Foldable (toList) import Data.IORef -import Data.List (last, partition, nub, drop, any) -import Data.List.Split (oneOf, split) +import Data.List (any, drop, last, nub, partition) +import Data.List.Split (oneOf, split) import Data.Maybe import Data.Ratio -import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) -import qualified Data.Sequence as Sq -import Data.Traversable (mapM) +import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) +import qualified Data.Sequence as Sq +import Data.Traversable (mapM) -import Data.Array ((!)) -import qualified Data.Array as Array -import Data.Map (unionWith, unionsWith, toAscList, singleton, Map, (!), empty) -import qualified Data.Map as M -import qualified Data.HashMap.Lazy as HL -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Vector as V +import Data.Array ((!)) +import qualified Data.Array as Array +import qualified Data.HashMap.Lazy as HL +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Map (Map, assocs, empty, singleton, + unionWith, unionsWith, (!)) +import qualified Data.Map as M +import qualified Data.Vector as V -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T -import Language.Egison.Parser as Parser +import Language.Egison.Parser as Parser import Language.Egison.ParserNonS as ParserNonS import Language.Egison.Types @@ -87,21 +91,21 @@ env <- recursiveBind env bindings forM_ rest $ evalTopExpr env return env - where - collectDefs :: [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr]) - collectDefs (expr:exprs) bindings rest = - case expr of - Define name expr -> collectDefs exprs ((name, expr) : bindings) rest - Load b file -> do - exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file - collectDefs (exprs' ++ exprs) bindings rest - LoadFile b file -> do - exprs' <- if b then Parser.loadFile file else ParserNonS.loadFile file - collectDefs (exprs' ++ exprs) bindings rest - Execute _ -> collectDefs exprs bindings (expr : rest) - _ -> collectDefs exprs bindings rest - collectDefs [] bindings rest = return (bindings, reverse rest) +collectDefs :: [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr]) +collectDefs (expr:exprs) bindings rest = + case expr of + Define name expr -> collectDefs exprs ((name, expr) : bindings) rest + Load b file -> do + exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file + collectDefs (exprs' ++ exprs) bindings rest + LoadFile b file -> do + exprs' <- if b then Parser.loadFile file else ParserNonS.loadFile file + collectDefs (exprs' ++ exprs) bindings rest + Execute _ -> collectDefs exprs bindings (expr : rest) + _ -> collectDefs exprs bindings rest +collectDefs [] bindings rest = return (bindings, reverse rest) + evalTopExprsTestOnly :: Env -> [EgisonTopExpr] -> EgisonM Env evalTopExprsTestOnly env exprs = do (bindings, rest) <- collectDefs exprs [] [] @@ -135,32 +139,38 @@ collectDefs (expr:exprs) bindings rest = case expr of Define name expr -> collectDefs exprs ((name, expr) : bindings) rest - Load _ _ -> throwError $ Default "No IO support" - LoadFile _ _ -> throwError $ Default "No IO support" + Load _ _ -> throwError $ Default "No IO support" + LoadFile _ _ -> throwError $ Default "No IO support" _ -> collectDefs exprs bindings (expr : rest) collectDefs [] bindings rest = return (bindings, reverse rest) evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env evalTopExpr env topExpr = do - ret <- evalTopExpr' env topExpr + ret <- evalTopExpr' (StateT $ \defines -> (, defines) <$> recursiveBind env defines) topExpr case fst ret of Nothing -> return () Just output -> liftIO $ putStrLn output - return $ snd ret + evalStateT (snd ret) [] -evalTopExpr' :: Env -> EgisonTopExpr -> EgisonM (Maybe String, Env) -evalTopExpr' env (Define name expr) = recursiveBind env [(name, expr)] >>= return . ((,) Nothing) -evalTopExpr' env (Redefine name expr) = recursiveRebind env (name, expr) >>= return . ((,) Nothing) -evalTopExpr' env (Test expr) = do - val <- evalExprDeep env expr - return (Just (show val), env) -evalTopExpr' env (Execute expr) = do - io <- evalExpr env expr +evalTopExpr' :: StateT [(Var, EgisonExpr)] EgisonM Env -> EgisonTopExpr -> EgisonM (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env) +evalTopExpr' st (Define name expr) = return (Nothing, withStateT (\defines -> (name, expr):defines) st) +evalTopExpr' st (Redefine name expr) = return (Nothing, mapStateT (>>= \(env, defines) -> (, defines) <$> recursiveRebind env (name, expr)) st) +evalTopExpr' st (Test expr) = do + val <- evalStateT st [] >>= flip evalExprDeep expr + return (Just (show val), st) +evalTopExpr' st (Execute expr) = do + io <- evalStateT st [] >>= flip evalExpr expr case io of - Value (IOFunc m) -> m >> return (Nothing, env) + Value (IOFunc m) -> m >> return (Nothing, st) _ -> throwError $ TypeMismatch "io" io -evalTopExpr' env (Load b file) = (if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file) >>= evalTopExprs env >>= return . ((,) Nothing) -evalTopExpr' env (LoadFile b file) = (if b then Parser.loadFile file else ParserNonS.loadFile file) >>= evalTopExprs env >>= return . ((,) Nothing) +evalTopExpr' st (Load b file) = do + exprs <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file + (bindings, _) <- collectDefs exprs [] [] + return (Nothing, withStateT (\defines -> bindings ++ defines) st) +evalTopExpr' st (LoadFile b file) = do + exprs <- if b then Parser.loadFile file else ParserNonS.loadFile file + (bindings, _) <- collectDefs exprs [] [] + return (Nothing, withStateT (\defines -> bindings ++ defines) st) evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c @@ -173,13 +183,13 @@ whnf <- evalExpr env expr case whnf of Value (ScalarData s) -> return . Value $ ScalarData $ Div (Plus [Term 1 [(Quote s, 1)]]) (Plus [Term 1 []]) - _ -> throwError $ TypeMismatch "scalar in quote" $ whnf + _ -> throwError $ TypeMismatch "scalar in quote" whnf evalExpr env (QuoteSymbolExpr expr) = do whnf <- evalExpr env expr case whnf of Value val -> return . Value $ QuotedFunc val - _ -> throwError $ TypeMismatch "value in quote-function" $ whnf + _ -> throwError $ TypeMismatch "value in quote-function" whnf evalExpr env (VarExpr name) = do x <- refVar' env name >>= evalRef @@ -219,26 +229,26 @@ refs' <- mapM (newObjectRef env) exprs return . Intermediate . IArray $ Array.listArray (1, toInteger (length exprs)) refs' -evalExpr env (VectorExpr exprs) = do - whnfs <- mapM (evalExpr env) exprs +evalExpr env@(Env frame maybe_vwi) (VectorExpr exprs) = do + whnfs <- mapM (\(expr, i) -> + let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList [toEgison $ toInteger i]) maybe_vwi in + evalExpr env' expr) $ zip exprs [1..(length exprs + 1)] case whnfs of - ((Intermediate (ITensor (Tensor _ _ _))):_) -> do - ret <- mapM toTensor (map f $ zip whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor - return ret + (Intermediate (ITensor Tensor{}):_) -> + mapM toTensor (zipWith (curry f) whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor _ -> fromTensor (Tensor [fromIntegral $ length whnfs] (V.fromList whnfs) []) where - f ((Intermediate (ITensor (Tensor ns xs indices))), i) = - Intermediate $ ITensor $ Tensor ns (V.fromList $ map g $ zip (V.toList xs) $ map (\ms -> map toEgison $ (toInteger i):ms) $ enumTensorIndices ns) indices + f (Intermediate (ITensor (Tensor ns xs indices)), i) = + Intermediate $ ITensor $ Tensor ns (V.fromList $ zipWith (curry g) (V.toList xs) $ map (\ms -> map toEgison $ toInteger i:ms) $ enumTensorIndices ns) indices f (x, _) = x g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)), ms) = - let Env _ maybe_vwi = env in let fn' = maybe fn (\(VarWithIndices nameString indexList) -> Just $ symbolScalarData "" $ show $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi in Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p g (x, _) = x evalExpr env (TensorExpr nsExpr xsExpr supExpr subExpr) = do nsWhnf <- evalExpr env nsExpr - ns <- ((fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer]) + ns <- (fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer] xsWhnf <- evalExpr env xsExpr xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef supWhnf <- evalExpr env supExpr @@ -247,7 +257,7 @@ sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar' if product ns == toInteger (length xs) then fromTensor (initTensor ns xs sup sub) - else throwError $ InconsistentTensorSize + else throwError InconsistentTensorSize evalExpr env (HashExpr assocs) = do let (keyExprs, exprs) = unzip assocs @@ -256,86 +266,86 @@ refs <- mapM (newObjectRef env) exprs case keys of [] -> do - let keys' = map (\key -> case key of IntKey i -> i) keys + let keys' = map (\case IntKey i -> i) keys return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs _ -> case head keys of IntKey _ -> do - let keys' = map (\key -> case key of IntKey i -> i) keys + let keys' = map (\ case IntKey i -> i) keys return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs CharKey _ -> do - let keys' = map (\key -> case key of CharKey c -> c) keys + let keys' = map (\case CharKey c -> c) keys return . Intermediate . ICharHash $ HL.fromList $ zip keys' refs StrKey _ -> do - let keys' = map (\key -> case key of StrKey s -> s) keys + let keys' = map (\case StrKey s -> s) keys return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs where makeHashKey :: WHNFData -> EgisonM EgisonHashKey makeHashKey (Value val) = case val of - ScalarData _ -> fromEgison val >>= (return . IntKey) + ScalarData _ -> IntKey <$> fromEgison val Char c -> return (CharKey c) String str -> return (StrKey str) _ -> throwError $ TypeMismatch "integer or string" $ Value val - makeHashKey whnf = throwError $ TypeMismatch "integer or string" $ whnf + makeHashKey whnf = throwError $ TypeMismatch "integer or string" whnf evalExpr env (IndexedExpr bool expr indices) = do tensor <- case expr of VarExpr (Var xs is) -> do - let mObjRef = refVar env (Var xs $ is ++ (map f indices)) + let mObjRef = refVar env (Var xs $ is ++ map f indices) case mObjRef of (Just objRef) -> evalRef objRef Nothing -> evalExpr env expr _ -> evalExpr env expr - js <- mapM (\i -> case i of - Superscript n -> evalExprDeep env n >>= return . Superscript - Subscript n -> evalExprDeep env n >>= return . Subscript - SupSubscript n -> evalExprDeep env n >>= return . SupSubscript - Userscript n -> evalExprDeep env n >>= return . Userscript + js <- mapM (\case + Superscript n -> Superscript <$> evalExprDeep env n + Subscript n -> Subscript <$> evalExprDeep env n + SupSubscript n -> SupSubscript <$> evalExprDeep env n + Userscript n -> Userscript <$> evalExprDeep env n ) indices ret <- case tensor of - (Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name [], 1)])]) (Plus [(Term 1 [])])))) -> do - js2 <- mapM (\i -> case i of - Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript - Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript - SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript - Userscript n -> evalExprDeep env n >>= extractScalar >>= return . Userscript + (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []])))) -> do + js2 <- mapM (\case + Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar) + Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar) + SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar) + Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar) ) indices - return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name js2, 1)])]) (Plus [(Term 1 [])]))) - (Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name js', 1)])]) (Plus [(Term 1 [])])))) -> do - js2 <- mapM (\i -> case i of - Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript - Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript - SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript - Userscript n -> evalExprDeep env n >>= extractScalar >>= return . Userscript + return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js2, 1)]]) (Plus [Term 1 []]))) + (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js', 1)]]) (Plus [Term 1 []])))) -> do + js2 <- mapM (\case + Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar) + Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar) + SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar) + Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar) ) indices - return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name (js' ++ js2), 1)])]) (Plus [(Term 1 [])]))) - (Value (TensorData (Tensor ns xs is))) -> do - if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value - else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value - (Intermediate (ITensor (Tensor ns xs is))) -> do + return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (js' ++ js2), 1)]]) (Plus [Term 1 []]))) + (Value (TensorData (Tensor ns xs is))) -> + if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor) + else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor) + (Intermediate (ITensor (Tensor ns xs is))) -> if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor _ -> do - js2 <- mapM (\i -> case i of - Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript - Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript - SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript - Userscript n -> evalExprDeep env n >>= extractScalar >>= return . Userscript + js2 <- mapM (\case + Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar) + Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar) + SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar) + Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar) ) indices - refArray tensor (map (\j -> case j of - Superscript k -> ScalarData k - Subscript k -> ScalarData k - SupSubscript k -> ScalarData k - Userscript k -> ScalarData k + refArray tensor (map (\case + Superscript k -> ScalarData k + Subscript k -> ScalarData k + SupSubscript k -> ScalarData k + Userscript k -> ScalarData k ) js2) let ret2 = case expr of - (VarExpr var) -> do + (VarExpr var) -> case ret of Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)) -> case fn of - Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show var ++ concat (map show indices)) argnames args js, 1)]]) p) + Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show var ++ concatMap show indices) argnames args js, 1)]]) p) Just s -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p) _ -> ret _ -> ret @@ -348,25 +358,24 @@ f (Userscript _) = Userscript () evalExpr env (SubrefsExpr bool expr jsExpr) = do - js <- evalExpr env jsExpr >>= collectionToList >>= return . (map Subscript) + js <- map Subscript <$> (evalExpr env jsExpr >>= collectionToList) tensor <- case expr of VarExpr (Var xs is) -> do - let mObjRef = refVar env (Var xs $ is ++ (take (length js) (repeat (Subscript ())))) + let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Subscript ())) case mObjRef of (Just objRef) -> evalRef objRef Nothing -> evalExpr env expr _ -> evalExpr env expr - ret <- case tensor of - (Value (ScalarData _)) -> do - return $ tensor - (Value (TensorData (Tensor ns xs is))) -> do - if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value - else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value - (Intermediate (ITensor (Tensor ns xs is))) -> do - if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor - else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor - _ -> throwError $ NotImplemented "subrefs" - return ret + case tensor of + (Value (ScalarData _)) -> + return tensor + (Value (TensorData (Tensor ns xs is))) -> + if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor) + else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor) + (Intermediate (ITensor (Tensor ns xs is))) -> + if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor + else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor + _ -> throwError $ NotImplemented "subrefs" where f :: Index a -> Index () f (Superscript _) = Superscript () @@ -375,25 +384,24 @@ f (Userscript _) = Userscript () evalExpr env (SuprefsExpr bool expr jsExpr) = do - js <- evalExpr env jsExpr >>= collectionToList >>= return . (map Superscript) + js <- map Superscript <$> (evalExpr env jsExpr >>= collectionToList) tensor <- case expr of VarExpr (Var xs is) -> do - let mObjRef = refVar env (Var xs $ is ++ (take (length js) (repeat (Superscript ())))) + let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Superscript ())) case mObjRef of (Just objRef) -> evalRef objRef Nothing -> evalExpr env expr _ -> evalExpr env expr - ret <- case tensor of - (Value (ScalarData _)) -> do - return $ tensor - (Value (TensorData (Tensor ns xs is))) -> do - if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value - else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value - (Intermediate (ITensor (Tensor ns xs is))) -> do - if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor - else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor - _ -> throwError $ NotImplemented "suprefs" - return ret + case tensor of + (Value (ScalarData _)) -> + return tensor + (Value (TensorData (Tensor ns xs is))) -> + if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor) + else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor) + (Intermediate (ITensor (Tensor ns xs is))) -> + if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor + else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor + _ -> throwError $ NotImplemented "suprefs" where f :: Index a -> Index () f (Superscript _) = Superscript () @@ -403,17 +411,16 @@ evalExpr env (UserrefsExpr bool expr jsExpr) = do val <- evalExprDeep env expr - js <- evalExpr env jsExpr >>= collectionToList >>= mapM extractScalar >>= return . (map Userscript) - ret <- case val of - (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []]))) - (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args (is ++ js), 1)]]) (Plus [Term 1 []]))) - _ -> throwError $ NotImplemented "user-refs" - return ret + js <- map Userscript <$> (evalExpr env jsExpr >>= collectionToList >>= mapM extractScalar) + case val of + (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []]))) + (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args (is ++ js), 1)]]) (Plus [Term 1 []]))) + _ -> throwError $ NotImplemented "user-refs" evalExpr env (LambdaExpr names expr) = do - names' <- mapM (\name -> case name of - (TensorArg name') -> return name' - (ScalarArg _) -> throwError $ EgisonBug "scalar-arg remained") names + names' <- mapM (\case + (TensorArg name') -> return name' + (ScalarArg _) -> throwError $ EgisonBug "scalar-arg remained") names return . Value $ Func Nothing env names' expr evalExpr env (PartialExpr n expr) = return . Value $ PartialFunc env n expr @@ -429,16 +436,16 @@ evalExpr (Env frame Nothing) (FunctionExpr args) = throwError $ Default "function symbol is not bound to a variable" evalExpr env@(Env frame (Just name)) (FunctionExpr args) = do - args' <- mapM (\arg -> evalExprDeep env arg) args - return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show name) (map (\x -> symbolScalarData "" $ show x) args) args' [], 1)]]) (Plus [Term 1 []])) + args' <- mapM (evalExprDeep env) args + return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show name) (map (symbolScalarData "" . show) args) args' [], 1)]]) (Plus [Term 1 []])) evalExpr env (SymbolicTensorExpr args sizeExpr name) = do - args' <- mapM (\arg -> evalExprDeep env arg) args + args' <- mapM (evalExprDeep env) args size' <- evalExpr env sizeExpr size'' <- collectionToList size' - ns <- (mapM fromEgison size'') :: EgisonM [Integer] - let xs = map (\ms -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" (name ++ concat (map (\m -> "_" ++ m) (map show ms)))) (map (\x -> symbolScalarData "" $ show x) args) args' [], 1)]]) (Plus [Term 1 []]))) - (map (\ms -> map toEgison ms) (enumTensorIndices ns)) + ns <- mapM fromEgison size'' :: EgisonM [Integer] + let xs = map ((\ms -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" (name ++ concatMap ((\m -> "_" ++ m) . show) ms)) (map (symbolScalarData "" . show) args) args' [], 1)]]) (Plus [Term 1 []]))) + . map toEgison) (enumTensorIndices ns) fromTensor (Tensor ns (V.fromList xs) []) evalExpr env (IfExpr test expr expr') = do @@ -501,17 +508,17 @@ evalExpr env (WithSymbolsExpr vars expr) = do symId <- fresh - syms <- mapM (\var -> (newEvaluatedObjectRef (Value (symbolScalarData symId var)))) vars + syms <- mapM (newEvaluatedObjectRef . Value . symbolScalarData symId) vars let bindings = zip (map stringToVar vars) syms whnf <- evalExpr (extendEnv env bindings) expr case whnf of - (Value (TensorData (Tensor ns xs js))) -> do + (Value (TensorData (Tensor ns xs js))) -> removeTmpscripts symId (Value (TensorData (Tensor ns xs js))) - (Intermediate (ITensor (Tensor ns xs js))) -> do + (Intermediate (ITensor (Tensor ns xs js))) -> removeTmpscripts symId (Intermediate (ITensor (Tensor ns xs js))) _ -> return whnf where - isTmpSymbol :: String -> (Index EgisonValue) -> Bool + isTmpSymbol :: String -> Index EgisonValue -> Bool isTmpSymbol symId (Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) | symId == id = True | otherwise = False @@ -533,7 +540,7 @@ let (ds, js) = partition (isTmpSymbol symId) is (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is) return (Value (TensorData (Tensor s ys js))) - removeDFscripts _ whnf = return whnf + removeDFscripts _ = return evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do @@ -564,13 +571,31 @@ head <- IElement <$> newEvaluatedObjectRef val tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList) seqRef <- liftIO . newIORef $ Sq.fromList [head, tail] - return . Intermediate $ ICollection $ seqRef + return . Intermediate $ ICollection seqRef f matcher target = do let tryMatchClause (pattern, expr) results = do - result <- patternMatch env pattern target matcher + result <- patternMatch BFSMode env pattern target matcher mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results mfoldr tryMatchClause (return MNil) (fromList clauses) +evalExpr env (MatchAllDFSExpr target matcher clauses) = do + target <- evalExpr env target + matcher <- evalExpr env matcher >>= evalMatcherWHNF + f matcher target >>= fromMList + where + fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData + fromMList MNil = return . Value $ Collection Sq.empty + fromMList (MCons val m) = do + head <- IElement <$> newEvaluatedObjectRef val + tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList) + seqRef <- liftIO . newIORef $ Sq.fromList [head, tail] + return . Intermediate $ ICollection seqRef + f matcher target = do + let tryMatchClause (pattern, expr) results = do + result <- patternMatch DFSMode env pattern target matcher + mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results + mfoldr tryMatchClause (return MNil) (fromList clauses) + evalExpr env (MatchExpr target matcher clauses) = do target <- evalExpr env target matcher <- evalExpr env matcher >>= evalMatcherWHNF @@ -578,7 +603,7 @@ where f matcher target = do let tryMatchClause (pattern, expr) cont = do - result <- patternMatch env pattern target matcher + result <- patternMatch BFSMode env pattern target matcher case result of MCons bindings _ -> evalExpr (extendEnv env bindings) expr MNil -> cont @@ -596,7 +621,7 @@ indices' <- mapM fromEgison args hash <- liftIO $ readIORef hashRef case HL.lookup indices' hash of - Just objRef -> do + Just objRef -> evalRef objRef Nothing -> do whnf <- applyFunc env (Value (Func Nothing env names body)) (Value (makeTuple args)) @@ -611,16 +636,16 @@ func <- evalExpr env func >>= appendDFscripts 0 arg <- evalExpr env arg case func of - Value (TensorData t@(Tensor ns fs js)) -> do - tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value >>= removeDFscripts - Intermediate (ITensor t@(Tensor ns fs js)) -> do + Value (TensorData t@(Tensor ns fs js)) -> + Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor) >>= removeDFscripts + Intermediate (ITensor t@(Tensor ns fs js)) -> tMap (\f -> applyFunc env f arg) t >>= fromTensor Value (MemoizedFunc name ref hashRef env names body) -> do indices <- evalWHNF arg indices' <- mapM fromEgison $ fromTupleValue indices hash <- liftIO $ readIORef hashRef case HL.lookup indices' hash of - Just objRef -> do + Just objRef -> evalRef objRef Nothing -> do whnf <- applyFunc env (Value (Func Nothing env names body)) arg @@ -635,18 +660,18 @@ func <- evalExpr env func >>= appendDFscripts 0 arg <- evalExpr env arg >>= fromTupleWHNF let k = fromIntegral (length arg) - arg <- mapM (\(i,j) -> appendDFscripts i j) (zip [1..k] arg) >>= makeITuple + arg <- zipWithM appendDFscripts [1..k] arg >>= makeITuple case func of - Value (TensorData t@(Tensor ns fs js)) -> do - tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value - Intermediate (ITensor t@(Tensor ns fs js)) -> do + Value (TensorData t@(Tensor ns fs js)) -> + Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor) + Intermediate (ITensor t@(Tensor ns fs js)) -> tMap (\f -> applyFunc env f arg) t >>= fromTensor Value (MemoizedFunc name ref hashRef env names body) -> do indices <- evalWHNF arg indices' <- mapM fromEgison $ fromTupleValue indices hash <- liftIO $ readIORef hashRef case HL.lookup indices' hash of - Just objRef -> do + Just objRef -> evalRef objRef Nothing -> do whnf <- applyFunc env (Value (Func Nothing env names body)) arg @@ -658,28 +683,26 @@ _ -> applyFunc env func arg >>= removeDFscripts evalExpr env (MemoizeExpr memoizeFrame expr) = do - mapM (\(x, y, z) -> do x' <- evalExprDeep env x - case x' of - (MemoizedFunc name ref hashRef env' names body) -> do - indices <- evalExprDeep env y - indices' <- mapM fromEgison $ fromTupleValue indices - hash <- liftIO $ readIORef hashRef - ret <- evalExprDeep env z - retRef <- newEvaluatedObjectRef (Value ret) - liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) - writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body)) - _ -> throwError $ TypeMismatch "memoized-function" (Value x')) + mapM_ (\(x, y, z) -> do x' <- evalExprDeep env x + case x' of + (MemoizedFunc name ref hashRef env' names body) -> do + indices <- evalExprDeep env y + indices' <- mapM fromEgison $ fromTupleValue indices + hash <- liftIO $ readIORef hashRef + ret <- evalExprDeep env z + retRef <- newEvaluatedObjectRef (Value ret) + liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) + writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body)) + _ -> throwError $ TypeMismatch "memoized-function" (Value x')) memoizeFrame evalExpr env expr -evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info BFSMode - -evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env info (DFSMode "umdfs") +evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info evalExpr env (GenerateArrayExpr fnExpr (fstExpr, lstExpr)) = do fN <- (evalExpr env fstExpr >>= fromWHNF) :: EgisonM Integer eN <- (evalExpr env lstExpr >>= fromWHNF) :: EgisonM Integer - xs <- mapM (\n -> (newObjectRef env (ApplyExpr fnExpr (IntegerExpr n)))) [fN..eN] + xs <- mapM (newObjectRef env . ApplyExpr fnExpr . IntegerExpr) [fN..eN] return $ Intermediate $ IArray $ Array.listArray (fN, eN) xs evalExpr env (ArrayBoundsExpr expr) = @@ -688,26 +711,26 @@ evalExpr env (GenerateTensorExpr fnExpr sizeExpr) = do size' <- evalExpr env sizeExpr size'' <- collectionToList size' - ns <- (mapM fromEgison size'') :: EgisonM [Integer] + ns <- mapM fromEgison size'' :: EgisonM [Integer] let Env frame maybe_vwi = env - xs <- mapM (\ms -> do + xs <- mapM ((\ms -> do let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi fn <- evalExpr env' fnExpr applyFunc env fn $ Value $ makeTuple ms) - (map (\ms -> map toEgison ms) $ enumTensorIndices ns) + . map toEgison) (enumTensorIndices ns) fromTensor (Tensor ns (V.fromList xs) []) evalExpr env (TensorContractExpr fnExpr tExpr) = do fn <- evalExpr env fnExpr whnf <- evalExpr env tExpr case whnf of - (Intermediate (ITensor t@(Tensor _ _ _))) -> do + (Intermediate (ITensor t@Tensor{})) -> do ts <- tContract t tMapN (\xs -> do xs' <- mapM newEvaluatedObjectRef xs applyFunc env fn (Intermediate (ITuple xs'))) ts >>= fromTensor - (Value (TensorData t@(Tensor _ _ _))) -> do + (Value (TensorData t@Tensor{})) -> do ts <- tContract t - tMapN (\xs -> applyFunc' env fn (Tuple xs)) ts >>= fromTensor >>= return . Value + Value <$> (tMapN (applyFunc' env fn . Tuple) ts >>= fromTensor) _ -> return whnf where applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue @@ -717,10 +740,10 @@ fn <- evalExpr env fnExpr whnf <- evalExpr env tExpr case whnf of - Intermediate (ITensor t) -> do + Intermediate (ITensor t) -> tMap (applyFunc env fn) t >>= fromTensor - Value (TensorData t) -> do - tMap (applyFunc' env fn) t >>= fromTensor >>= return . Value + Value (TensorData t) -> + Value <$> (tMap (applyFunc' env fn) t >>= fromTensor) _ -> applyFunc env fn whnf where applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue @@ -732,7 +755,7 @@ whnf2 <- evalExpr env t2Expr case (whnf1, whnf2) of -- both of arguments are tensors - (Intermediate (ITensor t1), Intermediate (ITensor t2)) -> do + (Intermediate (ITensor t1), Intermediate (ITensor t2)) -> tMap2 (applyFunc'' env fn) t1 t2 >>= fromTensor (Intermediate (ITensor t), Value (TensorData (Tensor ns xs js))) -> do let xs' = V.map Value xs @@ -740,20 +763,20 @@ (Value (TensorData (Tensor ns xs js)), Intermediate (ITensor t)) -> do let xs' = V.map Value xs tMap2 (applyFunc'' env fn) (Tensor ns xs' js) t >>= fromTensor - (Value (TensorData t1), Value (TensorData t2)) -> do - tMap2 (\x y -> applyFunc' env fn (Tuple [x, y])) t1 t2 >>= fromTensor >>= return . Value + (Value (TensorData t1), Value (TensorData t2)) -> + Value <$> (tMap2 (\x y -> applyFunc' env fn (Tuple [x, y])) t1 t2 >>= fromTensor) -- an argument is scalar (Intermediate (ITensor (Tensor ns xs js)), whnf) -> do - ys <- V.mapM (\x -> (applyFunc'' env fn x whnf)) xs + ys <- V.mapM (\x -> applyFunc'' env fn x whnf) xs return $ Intermediate (ITensor (Tensor ns ys js)) (whnf, Intermediate (ITensor (Tensor ns xs js))) -> do - ys <- V.mapM (\x -> (applyFunc'' env fn whnf x)) xs + ys <- V.mapM (applyFunc'' env fn whnf) xs return $ Intermediate (ITensor (Tensor ns ys js)) (Value (TensorData (Tensor ns xs js)), whnf) -> do - ys <- V.mapM (\x -> (applyFunc'' env fn (Value x) whnf)) xs + ys <- V.mapM (\x -> applyFunc'' env fn (Value x) whnf) xs return $ Intermediate (ITensor (Tensor ns ys js)) (whnf, Value (TensorData (Tensor ns xs js))) -> do - ys <- V.mapM (\x -> (applyFunc'' env fn whnf (Value x))) xs + ys <- V.mapM (applyFunc'' env fn whnf . Value) xs return $ Intermediate (ITensor (Tensor ns ys js)) _ -> applyFunc'' env fn whnf1 whnf2 where @@ -833,7 +856,7 @@ evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList) addscript :: (Index EgisonValue, Tensor a) -> Tensor a -addscript (subj, (Tensor s t i)) = (Tensor s t (i ++ [subj])) +addscript (subj, Tensor s t i) = Tensor s t (i ++ [subj]) valuetoTensor2 :: WHNFData -> Tensor WHNFData valuetoTensor2 (Intermediate (ITensor t)) = t @@ -841,32 +864,32 @@ applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData applyFunc env (Value (TensorData (Tensor s1 t1 i1))) tds = do tds <- fromTupleWHNF tds - if (length s1) > (length i1) && (all (\(Intermediate (ITensor (Tensor s u i))) -> ((length s) - (length i) == 1)) tds) + if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> (length s - length i == 1)) tds then do symId <- fresh let argnum = length tds - subjs = map (\symName -> Subscript $ symbolScalarData symId (show symName)) [1 .. argnum] - supjs = map (\symName -> Superscript $ symbolScalarData symId (show symName)) [1 .. argnum] + subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum] + supjs = map (Superscript . symbolScalarData symId . show) [1 .. argnum] dot <- evalExpr env (VarExpr $ stringToVar ".") - makeITuple ((Value (TensorData (Tensor s1 t1 (i1 ++ supjs)))):(map Intermediate (map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)))) >>= applyFunc env dot + makeITuple (Value (TensorData (Tensor s1 t1 (i1 ++ supjs))):map (Intermediate .ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)) >>= applyFunc env dot else throwError $ Default "applyfunc" applyFunc env (Intermediate (ITensor (Tensor s1 t1 i1))) tds = do tds <- fromTupleWHNF tds - if (length s1) > (length i1) && (all (\(Intermediate (ITensor (Tensor s u i))) -> ((length s) - (length i) == 1)) tds) + if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> (length s - length i == 1)) tds then do symId <- fresh let argnum = length tds - subjs = map (\symName -> Subscript $ symbolScalarData symId (show symName)) [1 .. argnum] - supjs = map (\symName -> Superscript $ symbolScalarData symId (show symName)) [1 .. argnum] + subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum] + supjs = map (Superscript . symbolScalarData symId . show) [1 .. argnum] dot <- evalExpr env (VarExpr $ stringToVar ".") - makeITuple (map Intermediate (ITensor (Tensor s1 t1 (i1 ++ supjs)):(map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)))) >>= applyFunc env dot + makeITuple (map Intermediate (ITensor (Tensor s1 t1 (i1 ++ supjs)):map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds))) >>= applyFunc env dot else throwError $ Default "applyfunc" applyFunc _ (Value (PartialFunc env n body)) arg = do refs <- fromTuple arg if n == fromIntegral (length refs) - then evalExpr (extendEnv env $ makeBindings (map (\n -> (stringToVar $ "::" ++ show n)) [1..n]) refs) body + then evalExpr (extendEnv env $ makeBindings (map (\n -> stringToVar $ "::" ++ show n) [1..n]) refs) body else throwError $ ArgumentsNumWithNames ["partial"] (fromIntegral n) (length refs) applyFunc _ (Value (Func _ env [name] body)) arg = do ref <- newEvaluatedObjectRef arg @@ -887,8 +910,8 @@ applyFunc _ (Value (CFunc _ env name body)) arg = do refs <- fromTuple arg seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs) - col <- liftIO . newIORef $ WHNF $ Intermediate $ ICollection $ seqRef - if length refs > 0 + col <- liftIO . newIORef $ WHNF $ Intermediate $ ICollection seqRef + if not (null refs) then evalExpr (extendEnv env $ makeBindings' [name] [col]) body else throwError $ ArgumentsNumWithNames [name] 1 0 applyFunc env (Value (Macro [name] body)) arg = do @@ -900,48 +923,50 @@ then evalExpr (extendEnv env $ makeBindings' names refs) body else throwError $ ArgumentsNumWithNames names (length names) (length refs) applyFunc _ (Value (PrimitiveFunc _ func)) arg = func arg -applyFunc _ (Value (IOFunc m)) arg = do +applyFunc _ (Value (IOFunc m)) arg = case arg of Value World -> m _ -> throwError $ TypeMismatch "world" arg applyFunc _ (Value (QuotedFunc fn)) arg = do args <- tupleToList arg mExprs <- mapM extractScalar args - return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])])))) -applyFunc _ (Value fn@(ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])])))) arg = do + return (Value (ScalarData (Div (Plus [Term 1 [(Apply fn mExprs, 1)]]) (Plus [Term 1 []])))) +applyFunc _ (Value fn@(ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])))) arg = do args <- tupleToList arg - mExprs <- mapM extractScalar args - return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])])))) + mExprs <- mapM (\arg -> case arg of + ScalarData _ -> extractScalar arg + _ -> throwError $ EgisonBug "to use undefined functions, you have to use ScalarData args") args + return (Value (ScalarData (Div (Plus [Term 1 [(Apply fn mExprs, 1)]]) (Plus [Term 1 []])))) applyFunc _ whnf _ = throwError $ TypeMismatch "function" whnf refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData refArray val [] = return val -refArray (Value (Array array)) (index:indices) = do +refArray (Value (Array array)) (index:indices) = if isInteger index - then do i <- (liftM fromInteger . fromEgison) index - if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array + then do i <- (fmap fromInteger . fromEgison) index + if (\(a,b) -> a <= i && i <= b) $ Array.bounds array then refArray (Value (array Array.! i)) indices else return $ Value Undefined else case index of - (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> do + (ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> do let (_,size) = Array.bounds array elms <- mapM (\arr -> refArray (Value arr) indices) (Array.elems array) elmRefs <- mapM newEvaluatedObjectRef elms return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs _ -> throwError $ TypeMismatch "integer or symbol" (Value index) -refArray (Intermediate (IArray array)) (index:indices) = do +refArray (Intermediate (IArray array)) (index:indices) = if isInteger index - then do i <- (liftM fromInteger . fromEgison) index - if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array + then do i <- (fmap fromInteger . fromEgison) index + if (\(a,b) -> a <= i && i <= b) $ Array.bounds array then let ref = array Array.! i in evalRef ref >>= flip refArray indices else return $ Value Undefined else case index of - (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> do + (ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> do let (_,size) = Array.bounds array let refs = Array.elems array arrs <- mapM evalRef refs - elms <- mapM (\arr -> refArray arr indices) arrs + elms <- mapM (`refArray` indices) arrs elmRefs <- mapM newEvaluatedObjectRef elms return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs _ -> throwError $ TypeMismatch "integer or symbol" (Value index) @@ -978,11 +1003,11 @@ refArray val _ = throwError $ TypeMismatch "array or hash" val arrayBounds :: WHNFData -> EgisonM WHNFData -arrayBounds val = arrayBounds' val >>= return . Value +arrayBounds val = Value <$> arrayBounds' val arrayBounds' :: WHNFData -> EgisonM EgisonValue -arrayBounds' (Intermediate (IArray arr)) = return $ Tuple [(toEgison (fst (Array.bounds arr))), (toEgison (snd (Array.bounds arr)))] -arrayBounds' (Value (Array arr)) = return $ Tuple [(toEgison (fst (Array.bounds arr))), (toEgison (snd (Array.bounds arr)))] +arrayBounds' (Intermediate (IArray arr)) = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))] +arrayBounds' (Value (Array arr)) = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))] arrayBounds' val = throwError $ TypeMismatch "array" val newThunk :: Env -> EgisonExpr -> Object @@ -1009,7 +1034,7 @@ refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr let env' = extendEnv env $ makeBindings names refs let Env frame _ = env' - zipWithM_ (\ref (name,expr) -> do + zipWithM_ (\ref (name,expr) -> case expr of MemoizedLambdaExpr names body -> do hashRef <- liftIO $ newIORef HL.empty @@ -1017,11 +1042,11 @@ LambdaExpr args body -> do whnf <- evalExpr env' expr case whnf of - (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ (Value (Func (Just name) env args body)) + (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body) CambdaExpr arg body -> do whnf <- evalExpr env' expr case whnf of - (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body)) + (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body) FunctionExpr args -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args _ | isVarWithIndices name -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) expr | otherwise -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) @@ -1042,11 +1067,11 @@ LambdaExpr args body -> do whnf <- evalExpr env expr case whnf of - (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ (Value (Func (Just name) env args body)) + (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body) CambdaExpr arg body -> do whnf <- evalExpr env expr case whnf of - (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body)) + (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body) _ -> liftIO . writeIORef ref . Thunk $ evalExpr env expr return env @@ -1054,52 +1079,26 @@ -- Pattern Match -- -patternMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match) -patternMatch env pattern target matcher@(UserMatcher _ _ (DFSMode id)) = processMStatesAll 0 MatchingStates { _normalTree = [[(msingleton (MState BFSMode env [] [] [MAtom (DFSPat id pattern) target matcher]))]], _orderedOrTrees = M.empty, _ids = [], _bool = True } -patternMatch env pattern target matcher = processMStatesAll 0 MatchingStates { _normalTree = [[(msingleton (MState BFSMode env [] [] [MAtom pattern target matcher]))]], _orderedOrTrees = M.empty, _ids = [], _bool = topDFS pattern && not (containBFS pattern) } +patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match) +patternMatch mode env pattern target matcher = processMStates mode [msingleton $ MState env [] [] [] [MAtom pattern target matcher]] -processMStatesAll :: Int -> MatchingStates -> EgisonM (MList EgisonM Match) -processMStatesAll depth streams = do - (matches, streams') <- (\(a, b) -> (fromList a, b)) <$> (processMStatesLine depth streams >>= extractMatches) - if null (streams' ^. normalTree) - then do matches' <- mapM (\id -> processMStatesAll 0 $ MatchingStates { _normalTree = convert ((streams' ^. orderedOrTrees) M.! id), _orderedOrTrees = M.empty, _ids = [], _bool = streams' ^. bool }) $ streams' ^. ids - mappend matches $ mconcat $ fromList matches' - else mappend matches $ processMStatesAll (depth + 1) streams' - where - convert :: Map Int [a] -> [[a]] - convert ms = let ((start, root), ms') = M.deleteFindMin ms in - M.foldlWithKey (\l k x -> let k' = k - start in - if length l <= k' then l ++ (replicate (k' - length l) []) ++ [x] - else let (xs, y:ys) = splitAt k' l in xs ++ (x:ys)) [root] ms' +processMStates :: PMMode -> [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match) +processMStates _ [] = return MNil +processMStates mode streams = do + (matches, streams') <- mapM (processMStates' mode) streams >>= extractMatches . concat + mappend (fromList matches) $ (processMStates mode) streams' -processMStatesLine :: Int -> MatchingStates -> EgisonM MatchingStates -processMStatesLine depth streams = do - (oomaps, idlist, nextlist) <- (concatTuple . unzip3) <$> mapM (processMStatesDorB (streams ^. bool) depth) (head $ streams ^. normalTree) - let oots = unionsWith (unionWith (++)) $ streams ^. orderedOrTrees:oomaps - let nt = mergeNT nextlist $ tail $ streams ^. normalTree - let ids' = nub $ idlist ++ (streams ^. ids) - return $ MatchingStates { _normalTree = nt, _orderedOrTrees = oots, _ids = ids', _bool = streams ^. bool } - where - concatTuple (a, b, c) = (concat a, concat b, concat c) - mergeNT :: [MList EgisonM MatchingState] -> [[MList EgisonM MatchingState]] -> [[MList EgisonM MatchingState]] - mergeNT [] oldnt = oldnt - mergeNT nodes [] = [nodes] - mergeNT nodes (x:oldnt) = (x ++ nodes):oldnt +processMStates' :: PMMode -> MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState] +processMStates' _ MNil = return [] +processMStates' BFSMode stream@(MCons _ _) = processMStatesBFS stream +processMStates' DFSMode stream@(MCons _ _) = processMStatesDFS stream gatherBindings :: MatchingState -> Maybe [Binding] -gatherBindings (MState _ _ _ bindings []) = return bindings -gatherBindings (MState _ _ _ bindings trees) = isResolved trees >> return bindings - where isResolved :: [MatchingTree] -> Maybe () - isResolved [] = return () - isResolved (MAtom _ _ _ : _) = Nothing - isResolved (MNode _ state : rest) = gatherBindings state >> isResolved rest +gatherBindings (MState _ _ [] bindings []) = return bindings +gatherBindings _ = Nothing -extractMatches :: MatchingStates -> EgisonM ([Match], MatchingStates) -extractMatches streams - | null (streams ^. normalTree) = return ([], streams) - | otherwise = do - (matches, s) <- extractMatches' ([], []) $ head $ streams ^. normalTree - return (matches, streams & normalTree .~ (s:(tail $ streams ^. normalTree))) +extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState]) +extractMatches = extractMatches' ([], []) where extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState]) extractMatches' (xs, ys) [] = return (xs, ys) @@ -1108,48 +1107,8 @@ extractMatches' (xs ++ [bindings], ys ++ [states']) rest extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest -processMStatesDorB :: Bool -> Int -> MList EgisonM MatchingState -> EgisonM ([Map Id (Map Int [MList EgisonM MatchingState])], [Id], [MList EgisonM MatchingState]) -processMStatesDorB _ _ MNil = return ([], [], []) -processMStatesDorB b depth stream@(MCons state stream') = - case topMAtom state of - MAtom (OrderedOrPat id _ _) _ _ -> do - let (state1, state2) = splitMStateOO state - (oots, ids, newStreams) <- processMStatesDorB b depth (MCons state1 stream') - return ((singleton id $ singleton depth [msingleton state2]):oots, ids ++ [id], newStreams) - MAtom (DFSPat id _) _ _ -> mmap (return . (modeTo $ DFSMode id)) stream >>= processMStatesDorB b depth - MAtom (BFSPat _) _ _ -> mmap (return . (modeTo BFSMode)) stream >>= processMStatesDorB b depth - _ -> case pmMode state of - DFSMode id | b -> (\x -> ([], [], x)) <$> processMStatesDFS stream - | otherwise -> do - newStreams <- processMStates (MCons state $ return MNil) - stream'' <- stream' - return ([singleton id (singleton depth [stream''])], [id], newStreams) - BFSMode -> (\x -> ([], [], x)) <$> processMStates stream - where - splitMStateOO :: MatchingState -> (MatchingState, MatchingState) - splitMStateOO (MState mode env loops bindings ((MAtom (OrderedOrPat _ pat1 pat2) target matcher) : trees)) = - (MState mode env loops bindings ((MAtom pat1 target matcher) : trees), MState mode env loops bindings ((MAtom pat2 target matcher) : trees)) - splitMStateOO (MState mode env loops bindings ((MAtom pat target matcher) : trees)) = - (MState mode env loops bindings [MAtom pat target matcher], MState mode env loops bindings trees) - splitMStateOO (MState mode env loops bindings ((MNode penv state') : trees)) = - let (state1, state2) = splitMStateOO state' - in (MState mode env loops bindings (MNode penv state1 : trees), MState mode env loops bindings ((MNode penv state2) : trees)) - -modeTo :: PMMode -> MatchingState -> MatchingState -modeTo mode (MState _ env loops bindings (mtree:mtrees)) = MState mode env loops bindings $ (rmPat mtree):mtrees - -rmPat :: MatchingTree -> MatchingTree -rmPat (MAtom (DFSPat _ pattern) target matcher) = MAtom pattern target matcher -rmPat (MAtom (BFSPat pattern) target matcher) = MAtom pattern target matcher -rmPat (MAtom pat target matcher) = MAtom pat target matcher -rmPat (MNode penv (MState mode env loops bindings (mtree:mtrees))) = MNode penv $ MState mode env loops bindings ((rmPat mtree):mtrees) - -topMAtom :: MatchingState -> MatchingTree -topMAtom (MState _ _ _ _ (mAtom@(MAtom _ _ _):_)) = mAtom -topMAtom (MState _ _ _ _ ((MNode _ mstate):_)) = topMAtom mstate - -processMStates :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)] -processMStates (MCons state stream) = do +processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)] +processMStatesBFS (MCons state stream) = do newStream <- processMState state newStream' <- stream return [newStream, newStream'] @@ -1160,63 +1119,74 @@ newStream <- mappend stream' stream return [newStream] +topMAtom :: MatchingState -> Maybe MatchingTree +topMAtom (MState _ _ _ _ (mAtom@MAtom{}:_)) = Just mAtom +topMAtom (MState _ _ _ _ (MNode _ mstate:_)) = topMAtom mstate +topMAtom _ = Nothing + processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState) processMState state = case topMAtom state of - MAtom (NotPat _) _ _ -> do + Just (MAtom (NotPat _) _ _) -> do let (state1, state2) = splitMState state - result <- processMStatesAll 0 $ MatchingStates { _normalTree = [[msingleton state1]], _orderedOrTrees = M.empty, _ids = [], _bool = False } + result <- processMStates BFSMode [msingleton state1] case result of MNil -> return $ msingleton state2 _ -> return MNil - MAtom (LaterPat _) _ _ -> do + Just (MAtom (LaterPat _) _ _) -> do let state' = swapMState state processMState' state' _ -> processMState' state where splitMState :: MatchingState -> (MatchingState, MatchingState) - splitMState (MState mode env loops bindings ((MAtom (NotPat pattern) target matcher) : trees)) = - (MState mode env loops bindings [MAtom pattern target matcher], MState mode env loops bindings trees) - splitMState (MState mode env loops bindings ((MNode penv state') : trees)) = + splitMState (MState env loops seqs bindings (MAtom (NotPat pattern) target matcher : trees)) = + (MState env loops seqs bindings [MAtom pattern target matcher], MState env loops seqs bindings trees) + splitMState (MState env loops seqs bindings (MNode penv state' : trees)) = let (state1, state2) = splitMState state' - in (MState mode env loops bindings [MNode penv state1], MState mode env loops bindings (MNode penv state2 : trees)) + in (MState env loops seqs bindings [MNode penv state1], MState env loops seqs bindings (MNode penv state2 : trees)) swapMState :: MatchingState -> MatchingState - swapMState (MState mode env loops bindings ((MAtom (LaterPat pattern) target matcher) : trees)) = - MState mode env loops bindings (trees ++ [MAtom pattern target matcher]) - swapMState (MState mode env loops bindings ((MNode penv state') : trees)) = + swapMState (MState env loops seqs bindings (MAtom (LaterPat pattern) target matcher : trees)) = + MState env loops seqs bindings (trees ++ [MAtom pattern target matcher]) + swapMState (MState env loops seqs bindings (MNode penv state' : trees)) = let state'' = swapMState state' - in MState mode env loops bindings ((MNode penv state''):trees) + in MState env loops seqs bindings (MNode penv state'':trees) processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState) -processMState' (MState _ _ _ _ []) = throwError $ EgisonBug "should not reach here (empty matching-state)" +processMState' (MState _ _ [] _ []) = throwError $ EgisonBug "should not reach here (empty matching-state)" -processMState' (MState _ _ _ _ ((MNode _ (MState _ _ _ _ [])):_)) = throwError $ EgisonBug "should not reach here (empty matching-node)" +processMState' (MState env loops (SeqPatContext stack SeqNilPat [] []:seqs) bindings []) = return $ msingleton $ (MState env loops seqs bindings stack) +processMState' (MState env loops (SeqPatContext stack seqPat mats tgts:seqs) bindings []) = do + let mat' = makeTuple mats + tgt' <- makeITuple tgts + return $ msingleton $ MState env loops seqs bindings (MAtom seqPat tgt' mat' : stack) -processMState' (MState mode env loops bindings (MNode penv (MState mode' env' loops' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) = +processMState' (MState _ _ _ _ (MNode _ (MState _ _ _ [] []):_)) = throwError $ EgisonBug "should not reach here (empty matching-node)" + +processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) = do case lookup name penv of Just pattern -> case trees' of - [] -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target matcher):trees) - _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target matcher):(MNode penv (MState mode' env' loops' bindings' trees')):trees) + [] -> return $ msingleton $ MState env loops seqs bindings ((MAtom pattern target matcher):trees) + _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name -processMState' (MState mode env loops bindings (MNode penv (MState mode' env' loops' bindings' ((MAtom (IndexedPat (VarPat name) indices) target matcher):trees')):trees)) = +processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' (MAtom (IndexedPat (VarPat name) indices) target matcher:trees')):trees)) = case lookup name penv of Just pattern -> do let env'' = extendEnvForNonLinearPatterns env' bindings loops' - indices' <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) indices - let pattern' = IndexedPat pattern $ map (\i -> IntegerExpr i) indices' + indices' <- mapM (evalExpr env'' >=> fmap fromInteger . fromWHNF) indices + let pattern' = IndexedPat pattern $ map IntegerExpr indices' case trees' of - [] -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern' target matcher):trees) - _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern' target matcher):(MNode penv (MState mode' env' loops' bindings' trees')):trees) + [] -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:trees) + _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name -processMState' (MState mode env loops bindings ((MNode penv state):trees)) = +processMState' (MState env loops seqs bindings (MNode penv state:trees)) = processMState' state >>= mmap (\state' -> case state' of - MState _ _ _ _ [] -> return $ MState mode env loops bindings trees - _ -> (return . MState mode env loops bindings . (: trees) . MNode penv) state') + MState _ _ _ _ [] -> return $ MState env loops seqs bindings trees + _ -> return $ MState env loops seqs bindings (MNode penv state':trees)) -processMState' (MState mode env loops bindings ((MAtom pattern target matcher):trees)) = +processMState' (MState env loops seqs bindings (MAtom pattern target matcher:trees)) = let env' = extendEnvForNonLinearPatterns env bindings loops in case pattern of NotPat _ -> throwError $ EgisonBug "should not reach here (not pattern)" @@ -1228,13 +1198,13 @@ extractBindings (names, expr) = makeBindings names <$> (evalExpr env' expr >>= fromTuple) in - liftM concat (mapM extractBindings bindings') - >>= (\b -> return $ msingleton $ MState mode env loops (b ++ bindings) ((MAtom pattern' target matcher):trees)) + fmap concat (mapM extractBindings bindings') + >>= (\b -> return $ msingleton $ MState env loops seqs (b ++ bindings) (MAtom pattern' target matcher:trees)) PredPat predicate -> do func <- evalExpr env' predicate let arg = target result <- applyFunc env func arg >>= fromWHNF - if result then return $ msingleton $ (MState mode env loops bindings trees) + if result then return $ msingleton $ MState env loops seqs bindings trees else return MNil PApplyPat func args -> do @@ -1242,11 +1212,11 @@ case func' of Value (PatternFunc env'' names expr) -> let penv = zip names args - in return $ msingleton $ MState mode env loops bindings (MNode penv (MState mode env'' [] [] [MAtom expr target matcher]) : trees) + in return $ msingleton $ MState env loops seqs bindings (MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees) _ -> throwError $ TypeMismatch "pattern constructor" func' - DApplyPat func args -> do - return $ msingleton $ (MState mode env loops bindings ((MAtom (InductivePat "apply" [func, (toListPat args)]) target matcher):trees)) + DApplyPat func args -> + return $ msingleton $ MState env loops seqs bindings (MAtom (InductivePat "apply" [func, toListPat args]) target matcher:trees) LoopPat name (LoopRange start ends endPat) pat pat' -> do startNum <- evalExpr env' start >>= fromWHNF :: (EgisonM Integer) @@ -1257,10 +1227,10 @@ endsRef <- newEvaluatedObjectRef ends' inners <- liftIO $ newIORef $ Sq.fromList [IElement endsRef] endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners))) - return $ msingleton $ MState mode env ((LoopPatContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees) + return $ msingleton $ MState env (LoopPatContext (name, startNumRef) endsRef' endPat pat pat':loops) seqs bindings (MAtom ContPat target matcher:trees) else do endsRef <- newEvaluatedObjectRef ends' - return $ msingleton $ MState mode env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees) + return $ msingleton $ MState env (LoopPatContext (name, startNumRef) endsRef endPat pat pat':loops) seqs bindings (MAtom ContPat target matcher:trees) ContPat -> case loops of [] -> throwError $ Default "cannot use cont pattern except in loop pattern" @@ -1280,46 +1250,50 @@ then return MNil else if startNum == carEndsNum then if b2 - then return $ fromList [MState mode env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees)] - else return $ fromList [MState mode env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees), MState mode env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] - else return $ fromList [MState mode env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] + then return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees)] + else return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees), MState env (LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)] + else return $ fromList [MState env (LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)] + SeqNilPat -> throwError $ EgisonBug "should not reach here (seq nil pattern)" + SeqConsPat pattern pattern' -> return $ msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher] + LaterPatVar -> + case seqs of + [] -> throwError $ Default "cannot use # out of seq patterns" + (SeqPatContext stack pat mats tgts:seqs) -> return $ msingleton $ MState env loops (SeqPatContext stack pat (matcher:mats) (target:tgts):seqs) bindings trees AndPat patterns -> let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees - in return $ msingleton $ MState mode env loops bindings trees' + in return $ msingleton $ MState env loops seqs bindings trees' OrPat patterns -> return $ fromList $ flip map patterns $ \pat -> - MState mode env loops bindings (MAtom pat target matcher : trees) + MState env loops seqs bindings (MAtom pat target matcher : trees) _ -> case matcher of - UserMatcher _ _ _ -> do - case pattern of - _ -> do - (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher - case (length patterns, length matchers) of - (1,1) -> do - mfor targetss $ \ref -> do - targets <- evalRef ref >>= (\x -> return [x]) - let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ MState mode env loops bindings trees' - _ -> do - mfor targetss $ \ref -> do - targets <- evalRef ref >>= fromTupleWHNF - let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ MState mode env loops bindings trees' + UserMatcher{} -> do + (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher + case (length patterns, length matchers) of + (1,1) -> + mfor targetss $ \ref -> do + targets <- evalRef ref >>= (\x -> return [x]) + let trees' = zipWith3 MAtom patterns targets matchers ++ trees + return $ MState env loops seqs bindings trees' + _ -> + mfor targetss $ \ref -> do + targets <- evalRef ref >>= fromTupleWHNF + let trees' = zipWith3 MAtom patterns targets matchers ++ trees + return $ MState env loops seqs bindings trees' Tuple matchers -> case pattern of - ValuePat _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees) - WildCard -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees) - PatVar _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees) - IndexedPat _ _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees) + ValuePat _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees) + WildCard -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees) + PatVar _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees) + IndexedPat _ _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees) TuplePat patterns -> do targets <- fromTupleWHNF target - if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return () - if not (length patterns == length matchers) then throwError $ ArgumentsNum (length patterns) (length matchers) else return () + when (length patterns /= length targets) $ throwError $ ArgumentsNum (length patterns) (length targets) + when (length patterns /= length matchers) $ throwError $ ArgumentsNum (length patterns) (length matchers) let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ msingleton $ MState mode env loops bindings trees' + return $ msingleton $ MState env loops seqs bindings trees' _ -> throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern Something -> @@ -1328,21 +1302,21 @@ val <- evalExprDeep env' valExpr tgtVal <- evalWHNF target if val == tgtVal - then return $ msingleton $ MState mode env loops bindings trees + then return $ msingleton $ MState env loops seqs bindings trees else return MNil - WildCard -> return $ msingleton $ MState mode env loops bindings trees + WildCard -> return $ msingleton $ MState env loops seqs bindings trees PatVar name -> do targetRef <- newEvaluatedObjectRef target - return $ msingleton $ MState mode env loops ((name, targetRef):bindings) trees + return $ msingleton $ MState env loops seqs ((name, targetRef):bindings) trees IndexedPat (PatVar name) indices -> do - indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices + indices <- mapM (evalExpr env' >=> fmap fromInteger . fromWHNF) indices case lookup name bindings of Just ref -> do obj <- evalRef ref >>= updateHash indices >>= newEvaluatedObjectRef - return $ msingleton $ MState mode env loops (subst name obj bindings) trees + return $ msingleton $ MState env loops seqs (subst name obj bindings) trees Nothing -> do obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef - return $ msingleton $ MState mode env loops ((name,obj):bindings) trees + return $ msingleton $ MState env loops seqs ((name,obj):bindings) trees where updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData updateHash [index] (Intermediate (IIntHash hash)) = do @@ -1353,26 +1327,26 @@ ref <- updateHash indices val >>= newEvaluatedObjectRef return . Intermediate . IIntHash $ HL.insert index ref hash updateHash indices (Value (IntHash hash)) = do - keys <- return $ HL.keys hash + let keys = HL.keys hash vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash updateHash indices (Intermediate $ IIntHash $ HL.fromList $ zip keys vals) updateHash _ v = throwError $ Default $ "expected hash value: " ++ show v 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 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 $ Default ("invalid indexed-pattern: " ++ show pattern) TuplePat patterns -> do targets <- fromTupleWHNF target - if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return () - let trees' = zipWith3 MAtom patterns targets (take (length patterns) (repeat Something)) ++ trees - return $ msingleton $ MState mode env loops bindings trees' + when (length patterns /= length targets) $ throwError $ ArgumentsNum (length patterns) (length targets) + let trees' = zipWith3 MAtom patterns targets (replicate (length patterns) Something) ++ trees + return $ msingleton $ MState env loops seqs bindings trees' _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ show pattern _ -> throwError $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher]) -inductiveMatch env pattern target (UserMatcher matcherEnv clauses _) = +inductiveMatch env pattern target (UserMatcher matcherEnv clauses) = foldr tryPPMatchClause failPPPatternMatch clauses where tryPPMatchClause (pat, matchers, clauses) cont = do @@ -1380,7 +1354,7 @@ case result of Just (patterns, bindings) -> do targetss <- foldr tryPDMatchClause failPDPatternMatch clauses - matchers <- evalExpr matcherEnv matchers >>= evalMatcherWHNF >>= (return . fromTupleValue) + matchers <- fromTupleValue <$> (evalExpr matcherEnv matchers >>= evalMatcherWHNF) return (patterns, targetss, matchers) where tryPDMatchClause (pat, expr) cont = do @@ -1452,7 +1426,7 @@ expandCollection :: WHNFData -> EgisonM (Seq Inner) expandCollection (Value (Collection vals)) = - mapM (liftM IElement . newEvaluatedObjectRef . Value) vals + mapM (fmap IElement . newEvaluatedObjectRef . Value) vals expandCollection (Intermediate (ICollection innersRef)) = liftIO $ readIORef innersRef expandCollection val = throwError $ TypeMismatch "collection" val @@ -1462,7 +1436,7 @@ inners <- liftIO $ readIORef innersRef case Sq.viewl inners of EmptyL -> return True - (ISubCollection ref') :< tInners -> do + ISubCollection ref' :< tInners -> do hInners <- evalRef ref' >>= expandCollection liftIO $ writeIORef innersRef (hInners >< tInners) isEmptyCollection coll @@ -1480,10 +1454,10 @@ inners <- liftIO $ readIORef innersRef case Sq.viewl inners of EmptyL -> matchFail - (IElement ref') :< tInners -> do + IElement ref' :< tInners -> do tInnersRef <- liftIO $ newIORef tInners lift $ (ref', ) <$> newEvaluatedObjectRef (Intermediate $ ICollection tInnersRef) - (ISubCollection ref') :< tInners -> do + ISubCollection ref' :< tInners -> do hInners <- lift $ evalRef ref' >>= expandCollection liftIO $ writeIORef innersRef (hInners >< tInners) unconsCollection coll @@ -1500,10 +1474,10 @@ inners <- liftIO $ readIORef innersRef case Sq.viewr inners of EmptyR -> matchFail - hInners :> (IElement ref') -> do + hInners :> IElement ref' -> do hInnersRef <- liftIO $ newIORef hInners lift $ (, ref') <$> newEvaluatedObjectRef (Intermediate $ ICollection hInnersRef) - hInners :> (ISubCollection ref') -> do + hInners :> ISubCollection ref' -> do tInners <- lift $ evalRef ref' >>= expandCollection liftIO $ writeIORef innersRef (hInners >< tInners) unsnocCollection coll @@ -1514,7 +1488,7 @@ evalMatcherWHNF :: WHNFData -> EgisonM Matcher evalMatcherWHNF (Value matcher@Something) = return matcher -evalMatcherWHNF (Value matcher@(UserMatcher _ _ _)) = return matcher +evalMatcherWHNF (Value matcher@UserMatcher{}) = return matcher evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms evalMatcherWHNF (Intermediate (ITuple refs)) = do whnfs <- mapM evalRef refs @@ -1527,7 +1501,7 @@ -- toListPat :: [EgisonPattern] -> EgisonPattern toListPat [] = InductivePat "nil" [] -toListPat (pat:pats) = InductivePat "cons" [pat, (toListPat pats)] +toListPat (pat:pats) = InductivePat "cons" [pat, toListPat pats] fromTuple :: WHNFData -> EgisonM [ObjectRef] fromTuple (Intermediate (ITuple refs)) = return refs @@ -1580,9 +1554,9 @@ makeTuple xs = Tuple xs makeITuple :: [WHNFData] -> EgisonM WHNFData -makeITuple [] = return $ Intermediate (ITuple []) -makeITuple [x] = return $ x -makeITuple xs = mapM newEvaluatedObjectRef xs >>= (return . Intermediate . ITuple) +makeITuple [] = return $ Intermediate (ITuple []) +makeITuple [x] = return x +makeITuple xs = Intermediate . ITuple <$> mapM newEvaluatedObjectRef xs -- -- String @@ -1619,5 +1593,3 @@ isPrimitiveValue (Value (ScalarData _)) = True isPrimitiveValue (Value (Float _ _)) = True isPrimitiveValue _ = False - -makeLenses ''MatchingStates 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 @@ -1,4 +1,6 @@ -{-# Language FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {- | Module : Language.Egison.Desugar @@ -17,18 +19,19 @@ , desugar ) where -import Control.Applicative (Applicative) -import Control.Applicative ((<$>), (<*>), (<*), (*>), pure) -import qualified Data.Sequence as Sq -import Data.Sequence (ViewL(..), (<|)) -import qualified Data.Set as S -import Data.List (span) -import Data.Set (Set) -import Data.Char (toUpper) -import Control.Monad.Except -import Control.Monad.Fail -import Control.Monad.Reader -import Language.Egison.Types +import Control.Applicative (Applicative, pure, (*>), (<$>), (<*), + (<*>)) +import Control.Monad.Except +import Control.Monad.Fail +import Control.Monad.Reader +import Data.Char (toUpper) +import Data.List (span) +import Data.Maybe (fromMaybe) +import Data.Sequence (ViewL (..), (<|)) +import qualified Data.Sequence as Sq +import Data.Set (Set) +import qualified Data.Set as S +import Language.Egison.Types type Subst = [(String, EgisonExpr)] @@ -62,7 +65,7 @@ desugar :: EgisonExpr -> DesugarM EgisonExpr desugar (AlgebraicDataMatcherExpr patterns) = do matcherName <- freshV - matcherRef <- return $ VarExpr matcherName + let matcherRef = VarExpr matcherName matcher <- genMatcherClauses patterns matcherRef return $ LetRecExpr [([matcherName], matcher)] matcherRef where @@ -71,20 +74,20 @@ main <- genMainClause patterns matcher body <- mapM genMatcherClause patterns footer <- genSomethingClause - clauses <- return $ [main] ++ body ++ [footer] + let clauses = [main] ++ body ++ [footer] return $ MatcherExpr clauses genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genMainClause patterns matcher = do clauses <- genClauses patterns return (PPValuePat "val", TupleExpr [] - ,[(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr $ stringToVar "val"), (VarExpr $ stringToVar "tgt")]) - (TupleExpr [matcher, matcher]) - clauses))]) + ,[(PDPatVar "tgt", MatchExpr (TupleExpr [VarExpr $ stringToVar "val", VarExpr $ stringToVar "tgt"]) + (TupleExpr [matcher, matcher]) + clauses)]) where genClauses :: [(String, [EgisonExpr])] -> DesugarM [MatchClause] genClauses patterns = (++) <$> mapM genClause patterns - <*> pure [((TuplePat [WildCard, WildCard]), matchingFailure)] + <*> pure [(TuplePat [WildCard, WildCard], matchingFailure)] genClause :: (String, [EgisonExpr]) -> DesugarM MatchClause genClause pattern = do @@ -94,8 +97,8 @@ genMatchingPattern :: (String, [EgisonExpr]) -> DesugarM (EgisonPattern, EgisonPattern) genMatchingPattern (name, patterns) = do names <- mapM (const freshV) patterns - return $ ((InductivePat name (map PatVar names)) - ,(InductivePat name (map (ValuePat . VarExpr) names))) + return (InductivePat name (map PatVar names), + InductivePat name (map (ValuePat . VarExpr) names)) genMatcherClause :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genMatcherClause pattern = do @@ -112,7 +115,7 @@ genPrimitiveDataPat :: (String, [EgisonExpr]) -> DesugarM (PrimitiveDataPattern, [EgisonExpr]) genPrimitiveDataPat (name, patterns) = do patterns' <- mapM (const freshV) patterns - return (PDInductivePat (capitalize name) $ map PDPatVar $ map show patterns', map VarExpr patterns') + return (PDInductivePat (capitalize name) $ map (PDPatVar . show) patterns', map VarExpr patterns') capitalize :: String -> String capitalize (x:xs) = toUpper x : xs @@ -120,7 +123,7 @@ genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genSomethingClause = - return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr $ stringToVar "tgt")])]) + return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr $ stringToVar "tgt")])]) matchingSuccess :: EgisonExpr matchingSuccess = CollectionExpr [ElementExpr $ TupleExpr []] @@ -143,30 +146,30 @@ desugar (IndexedExpr b expr indices) | endWithThreeDots expr = case expr of - (VarExpr name) -> let x = show name in desugar $ IndexedExpr False (VarExpr $ stringToVar $ take ((length x)-3) x) indices + (VarExpr name) -> let x = show name in desugar $ IndexedExpr False (VarExpr $ stringToVar $ take (length x - 3) x) indices | otherwise = case indices of [Subscript x, DotSubscript y] -> case (x, y) of (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [x, y])) (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do k <- fresh return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "map") - (TupleExpr [(LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [(Subscript $ VarExpr $ stringToVar k)])), - (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [(fromIndexToExpr n1), (fromIndexToExpr n2)]))])) + (TupleExpr [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ VarExpr $ stringToVar k]), + ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [fromIndexToExpr n1, fromIndexToExpr n2])])) [Superscript x, DotSupscript y] -> case (x, y) of (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [x, y])) (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do k <- fresh return $ SuprefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "map") - (TupleExpr [(LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [(Subscript $ VarExpr $ stringToVar k)])), - (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [(fromIndexToExpr n1), (fromIndexToExpr n2)]))])) - _ -> IndexedExpr b <$> desugar expr <*> (mapM desugarIndex indices) + (TupleExpr [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ VarExpr $ stringToVar k]), + ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [fromIndexToExpr n1, fromIndexToExpr n2])])) + _ -> IndexedExpr b <$> desugar expr <*> mapM desugarIndex indices where endWithThreeDots :: EgisonExpr -> Bool - endWithThreeDots (VarExpr name) = (take 3 $ reverse (show name)) == "..." - endWithThreeDots _ = False + endWithThreeDots (VarExpr name) = take 3 (reverse (show name)) == "..." + endWithThreeDots _ = False fromIndexToExpr :: Index EgisonExpr -> EgisonExpr - fromIndexToExpr (Subscript a) = a - fromIndexToExpr (Superscript a) = a + fromIndexToExpr (Subscript a) = a + fromIndexToExpr (Superscript a) = a fromIndexToExpr (SupSubscript a) = a desugar (SubrefsExpr bool expr1 expr2) = @@ -194,12 +197,12 @@ desugar expr@(CollectionExpr []) = return expr -desugar (CollectionExpr ((ElementExpr elm):inners)) = do +desugar (CollectionExpr (ElementExpr elm:inners)) = do elm' <- desugar elm (CollectionExpr inners') <- desugar (CollectionExpr inners) return $ CollectionExpr (ElementExpr elm':inners') -desugar (CollectionExpr ((SubCollectionExpr sub):inners)) = do +desugar (CollectionExpr (SubCollectionExpr sub:inners)) = do sub' <- desugar sub (CollectionExpr inners') <- desugar (CollectionExpr inners) return $ CollectionExpr (SubCollectionExpr sub':inners') @@ -214,16 +217,15 @@ return $ TensorExpr nsExpr' xsExpr' supExpr subExpr desugar (LambdaExpr names expr) = do - let (rtnames, rhnames) = span (\name -> case name of - TensorArg _ -> True - _ -> False) (reverse names) + let (rtnames, rhnames) = span (\case + TensorArg _ -> True + _ -> False) (reverse names) case rhnames of [] -> do expr' <- desugar expr return $ LambdaExpr names expr' (InvertedScalarArg rhname:rhnames') -> do - let (rtnames2, rhnames2) = span (\name -> case name of - _ -> False) rhnames' + let (rtnames2, rhnames2) = span (const False) rhnames' case rhnames2 of [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames) (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (FlipIndicesExpr (VarExpr $ stringToVar rhname))) @@ -235,9 +237,9 @@ (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (FlipIndicesExpr (VarExpr $ stringToVar rhname2)) (FlipIndicesExpr (VarExpr $ stringToVar rhname))) (ScalarArg rhname:rhnames') -> do - let (rtnames2, rhnames2) = span (\name -> case name of - TensorArg _ -> True - _ -> False) rhnames' + let (rtnames2, rhnames2) = span (\case + TensorArg _ -> True + _ -> False) rhnames' case rhnames2 of [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames) (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (VarExpr $ stringToVar rhname)) @@ -302,7 +304,7 @@ expr0' <- desugar expr0 expr1' <- desugar expr1 clauses' <- desugarMatchClauses clauses - return (MatchExpr expr0' expr1' clauses') + return $ MatchExpr expr0' expr1' clauses' desugar (MatchAllExpr expr0 expr1 clauses) = do expr0' <- desugar expr0 @@ -310,6 +312,12 @@ clauses' <- desugarMatchClauses clauses return $ MatchAllExpr expr0' expr1' clauses' +desugar (MatchAllDFSExpr expr0 expr1 clauses) = do + expr0' <- desugar expr0 + expr1' <- desugar expr1 + clauses' <- desugarMatchClauses clauses + return $ MatchAllDFSExpr expr0' expr1' clauses' + desugar (DoExpr binds expr) = do binds' <- desugarBindings binds expr' <- desugar expr @@ -385,8 +393,8 @@ expr1' <- desugar expr1 return $ CApplyExpr expr0' expr1' -desugar (VarExpr name) = do - asks $ maybe (VarExpr name) id . lookup (show name) +desugar (VarExpr name) = + asks $ fromMaybe (VarExpr name) . lookup (show name) desugar FreshVarExpr = do id <- fresh @@ -396,10 +404,6 @@ matcherInfo' <- desugarMatcherInfo matcherInfo return $ MatcherExpr matcherInfo' -desugar (MatcherDFSExpr matcherInfo) = do - matcherInfo' <- desugarMatcherInfo matcherInfo - return $ MatcherDFSExpr matcherInfo' - desugar (PartialVarExpr n) = return $ PartialVarExpr n desugar (PartialExpr n expr) = do @@ -422,10 +426,10 @@ desugar expr = return expr desugarIndex :: Index EgisonExpr -> DesugarM (Index EgisonExpr) -desugarIndex (Superscript expr) = desugar expr >>= return . Superscript -desugarIndex (Subscript expr) = desugar expr >>= return . Subscript -desugarIndex (SupSubscript expr) = desugar expr >>= return . SupSubscript -desugarIndex (Userscript expr) = desugar expr >>= return . Userscript +desugarIndex (Superscript expr) = Superscript <$> desugar expr +desugarIndex (Subscript expr) = Subscript <$> desugar expr +desugarIndex (SupSubscript expr) = SupSubscript <$> desugar expr +desugarIndex (Userscript expr) = Userscript <$> desugar expr desugarPattern :: EgisonPattern -> DesugarM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern @@ -449,8 +453,6 @@ collectName (PlusPat patterns) = collectNames patterns collectName (MultPat patterns) = collectNames patterns collectName (PowerPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 - collectName (DFSPat _ pattern) = collectName pattern - collectName (BFSPat pattern) = collectName pattern collectName _ = S.empty makeBinding :: String -> BindingExpr @@ -463,8 +465,6 @@ desugarPattern' (LaterPat pattern) = LaterPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (OrPat patterns) = OrPat <$> mapM desugarPattern' patterns -desugarPattern' (OrderedOrPat' [pat1, pat2]) = OrderedOrPat <$> fresh <*> desugarPattern' pat1 <*> desugarPattern' pat2 -desugarPattern' (OrderedOrPat' (pat : patterns)) = OrderedOrPat <$> fresh <*> desugarPattern' pat <*> desugarPattern' (OrderedOrPat' patterns) desugarPattern' (TuplePat patterns) = TuplePat <$> mapM desugarPattern' patterns desugarPattern' (InductivePat name patterns) = InductivePat name <$> mapM desugarPattern' patterns desugarPattern' (IndexedPat pattern exprs) = IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs @@ -472,23 +472,24 @@ desugarPattern' (DApplyPat pattern patterns) = DApplyPat <$> desugarPattern' pattern <*> mapM desugarPattern' patterns desugarPattern' (LoopPat name range pattern1 pattern2) = LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (LetPat binds pattern) = LetPat <$> desugarBindings binds <*> desugarPattern' pattern +desugarPattern' (SeqConsPat pattern1 pattern2) = SeqConsPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (DivPat pattern1 pattern2) = do pat1' <- desugarPattern' pattern1 pat2' <- desugarPattern' pattern2 return $ InductivePat "div" [pat1', pat2'] desugarPattern' (PlusPat patterns) = do pats' <- mapM desugarPattern' (concatMap f patterns) - case (reverse pats') of + case reverse pats' of [] -> return $ InductivePat "plus" [ValuePat (IntegerExpr 0)] lp:hps -> return $ InductivePat "plus" [foldr (\p r -> InductivePat "cons" [p, r]) lp (reverse hps)] where f (PlusPat xs) = concatMap f xs - f pat = [pat] + f pat = [pat] desugarPattern' (MultPat (intPat:patterns)) = do intPat' <- desugarPattern' intPat pats' <- mapM desugarPattern' (concatMap f patterns) - case (reverse pats') of + case reverse pats' of [] -> return $ InductivePat "mult" [intPat', ValuePat (IntegerExpr 1)] lp:hps -> return $ InductivePat "mult" [intPat', @@ -501,27 +502,10 @@ (reverse hps)] where f (MultPat xs) = concatMap f xs - f pat = [pat] + f pat = [pat] desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 -desugarPattern' (DFSPat' pattern) = desugarPattern' pattern >>= dfs -desugarPattern' (BFSPat pattern) = BFSPat <$> desugarPattern' pattern desugarPattern' pattern = return pattern -dfs :: EgisonPattern -> DesugarM EgisonPattern -dfs (NotPat pattern) = NotPat <$> dfs pattern -dfs (AndPat patterns) = DFSPat <$> fresh <*> (AndPat <$> mapM dfs patterns) -dfs (OrPat patterns) = DFSPat <$> fresh <*> (OrPat <$> mapM dfs patterns) -dfs (OrderedOrPat id pat1 pat2) = OrderedOrPat id <$> dfs pat1 <*> dfs pat2 -dfs (TuplePat patterns) = DFSPat <$> fresh <*> (TuplePat <$> mapM dfs patterns) -dfs (InductivePat name patterns) = DFSPat <$> fresh <*> (InductivePat name <$> mapM dfs patterns) -dfs (IndexedPat pattern exprs) = DFSPat <$> fresh <*> (flip IndexedPat exprs <$> dfs pattern) -dfs (PApplyPat expr patterns) = DFSPat <$> fresh <*> (PApplyPat expr <$> mapM dfs patterns) -dfs (DApplyPat pattern patterns) = DFSPat <$> fresh <*> (DApplyPat <$> dfs pattern <*> mapM dfs patterns) -dfs (LoopPat name range pattern1 pattern2) = DFSPat <$> fresh <*> (LoopPat name range <$> dfs pattern1 <*> dfs pattern2) -dfs (LetPat binds pattern) = DFSPat <$> fresh <*> (LetPat binds <$> dfs pattern) -dfs (PowerPat pattern1 pattern2) = DFSPat <$> fresh <*> (PowerPat <$> dfs pattern1 <*> dfs pattern2) -dfs pattern = return pattern - desugarLoopRange :: LoopRange -> DesugarM LoopRange desugarLoopRange (LoopRange sExpr eExpr pattern) = do sExpr' <- desugar sExpr @@ -532,7 +516,7 @@ desugarBinding :: BindingExpr -> DesugarM BindingExpr desugarBinding (name, expr) = do expr' <- desugar expr - return $ (name, expr') + return (name, expr') desugarBindings :: [BindingExpr] -> DesugarM [BindingExpr] desugarBindings (bind:rest) = do @@ -546,7 +530,7 @@ desugarMatchClause (pattern, expr) = do pattern' <- desugarPattern pattern expr' <- desugar expr - return $ (pattern', expr') + return (pattern', expr') desugarMatchClauses :: [MatchClause] -> DesugarM [MatchClause] desugarMatchClauses (clause:rest) = do diff --git a/hs-src/Language/Egison/MathOutput.hs b/hs-src/Language/Egison/MathOutput.hs --- a/hs-src/Language/Egison/MathOutput.hs +++ b/hs-src/Language/Egison/MathOutput.hs @@ -6,31 +6,44 @@ This module provides utility functions. -} -module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex, mathExprToMathematica) where +module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex, mathExprToMathematica, mathExprToMaxima) where -import Control.Monad -import System.Environment -import Text.ParserCombinators.Parsec hiding (spaces) +import Control.Monad +import System.Environment +import Text.ParserCombinators.Parsec hiding (spaces) mathExprToHaskell :: String -> String mathExprToHaskell input = case parse parseExpr "math-expr" input of - Left err -> input + Left err -> input Right val -> "#haskell|" ++ show val ++ "|#" mathExprToAsciiMath :: String -> String mathExprToAsciiMath input = case parse parseExpr "math-expr" input of Left err -> input - Right val -> "#asciimath|" ++ showMathExprAsciiMath val ++ "|#" + Right val -> case showMathExprAsciiMath val of + "undefined" -> "undefined" + output -> "#asciimath|" ++ output ++ "|#" mathExprToLatex :: String -> String mathExprToLatex input = case parse parseExpr "math-expr" input of Left err -> input - Right val -> "#latex|" ++ showMathExprLatex val ++ "|#" + Right val -> case showMathExprLatex val of + "undefined" -> "undefined" + output -> "#latex|" ++ output ++ "|#" mathExprToMathematica :: String -> String mathExprToMathematica input = case parse parseExpr "math-expr" input of + Left err -> input + Right val -> case showMathExprMathematica val of + "undefined" -> "undefined" + output -> "#mathematica|" ++ output ++ "|#" + +mathExprToMaxima :: String -> String +mathExprToMaxima input = case parse parseExpr "math-expr" input of Left err -> input - Right val -> "#mathematica|" ++ showMathExprMathematica val ++ "|#" + Right val -> case showMathExprMaxima val of + "undefined" -> "undefined" + output -> "#maxima|" ++ output ++ "|#" data MathExpr = Atom String [MathIndex] | NegativeAtom String @@ -62,19 +75,19 @@ where showMathExprAsciiMathForPlus :: [MathExpr] -> String showMathExprAsciiMathForPlus [] = "" - showMathExprAsciiMathForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprAsciiMathForPlus xs - showMathExprAsciiMathForPlus ((Multiply (NegativeAtom "1":ys)):xs) = " - " ++ showMathExprAsciiMath (Multiply ys) ++ showMathExprAsciiMathForPlus xs - showMathExprAsciiMathForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprAsciiMath (Multiply ((Atom a []):ys)) ++ " " ++ showMathExprAsciiMathForPlus xs + showMathExprAsciiMathForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprAsciiMathForPlus xs + showMathExprAsciiMathForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprAsciiMath (Multiply ys) ++ showMathExprAsciiMathForPlus xs + showMathExprAsciiMathForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprAsciiMath (Multiply (Atom a []:ys)) ++ " " ++ showMathExprAsciiMathForPlus xs showMathExprAsciiMathForPlus (x:xs) = " + " ++ showMathExprAsciiMath x ++ showMathExprAsciiMathForPlus xs showMathExprAsciiMath (Multiply []) = "" showMathExprAsciiMath (Multiply [a]) = showMathExprAsciiMath a showMathExprAsciiMath (Multiply (NegativeAtom "1":lvs)) = "-" ++ showMathExprAsciiMath (Multiply lvs) showMathExprAsciiMath (Multiply lvs) = showMathExprAsciiMath' (head lvs) ++ " " ++ showMathExprAsciiMath (Multiply (tail lvs)) showMathExprAsciiMath (Power lv1 lv2) = showMathExprAsciiMath lv1 ++ "^" ++ showMathExprAsciiMath lv2 -showMathExprAsciiMath (Func f lvs) = case f of - Atom "/" [] -> if length lvs == 2 then "frac{" ++ showMathExprAsciiMath (head lvs) ++ "}{" ++ showMathExprAsciiMath (lvs !! 1) ++ "}" - else showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")" - _ -> showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")" +showMathExprAsciiMath (Func (Atom "sqrt" []) [x]) = "sqrt " ++ showMathExprAsciiMath x +showMathExprAsciiMath (Func (Atom "rt" []) [x, y]) = "root " ++ showMathExprAsciiMath x ++ " " ++ showMathExprAsciiMath y +showMathExprAsciiMath (Func (Atom "/" []) [x, y]) = "frac{" ++ showMathExprAsciiMath x ++ "}{" ++ showMathExprAsciiMath y ++ "}" +showMathExprAsciiMath (Func f lvs) = showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")" showMathExprAsciiMath (Tensor lvs mis) | null mis = "(" ++ showMathExprAsciiMathArg lvs ++ ")" | not (any isSub mis) = "(" ++ showMathExprAsciiMathArg lvs ++ ")^(" ++ showMathExprAsciiMathIndices mis ++ ")" @@ -85,9 +98,8 @@ showMathExprAsciiMath (Exp x) = "e^(" ++ showMathExprAsciiMath x ++ ")" isSub :: MathIndex -> Bool -isSub x = case x of - Sub _ -> True - _ -> False +isSub (Sub _) = True +isSub _ = False showMathExprAsciiMath' :: MathExpr -> String showMathExprAsciiMath' (Plus lvs) = "(" ++ showMathExprAsciiMath (Plus lvs) ++ ")" @@ -96,7 +108,7 @@ showMathExprAsciiMathArg :: [MathExpr] -> String showMathExprAsciiMathArg [] = "" showMathExprAsciiMathArg [a] = showMathExprAsciiMath a -showMathExprAsciiMathArg lvs = showMathExprAsciiMath (head lvs) ++ ", " ++ (showMathExprAsciiMathArg (tail lvs)) +showMathExprAsciiMathArg lvs = showMathExprAsciiMath (head lvs) ++ ", " ++ showMathExprAsciiMathArg (tail lvs) showMathExprAsciiMathIndices :: [MathIndex] -> String showMathExprAsciiMathIndices [a] = showMathIndexAsciiMath a @@ -104,7 +116,7 @@ showMathIndexAsciiMath :: MathIndex -> String showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a -showMathIndexAsciiMath (Sub a) = showMathExprAsciiMath a +showMathIndexAsciiMath (Sub a) = showMathExprAsciiMath a -- -- Show (Latex) @@ -114,25 +126,26 @@ showMathExprLatex (Atom a []) = a showMathExprLatex (Atom a xs) = a ++ showMathExprLatexScript xs showMathExprLatex (Partial f xs) = "\\frac{" ++ convertToPartial (f, length xs) ++ "}{" ++ showPartial xs ++ "}" - where showPartial :: [MathExpr] -> String - showPartial xs = let lx = elemCount xs in convertToPartial2 (head lx) ++ foldr (\x acc -> " " ++ convertToPartial2 x ++ acc) "" (tail lx) + where + showPartial :: [MathExpr] -> String + showPartial xs = let lx = elemCount xs in convertToPartial2 (head lx) ++ foldr (\x acc -> " " ++ convertToPartial2 x ++ acc) "" (tail lx) - convertToPartial :: (MathExpr, Int) -> String - convertToPartial (x, 1) = "\\partial " ++ showMathExprLatex x - convertToPartial (x, n) = "\\partial^" ++ show n ++ " " ++ showMathExprLatex x + convertToPartial :: (MathExpr, Int) -> String + convertToPartial (x, 1) = "\\partial " ++ showMathExprLatex x + convertToPartial (x, n) = "\\partial^" ++ show n ++ " " ++ showMathExprLatex x - convertToPartial2 :: (MathExpr, Int) -> String - convertToPartial2 (x, 1) = "\\partial " ++ showMathExprLatex x - convertToPartial2 (x, n) = "\\partial " ++ showMathExprLatex x ++ "^" ++ show n + convertToPartial2 :: (MathExpr, Int) -> String + convertToPartial2 (x, 1) = "\\partial " ++ showMathExprLatex x + convertToPartial2 (x, n) = "\\partial " ++ showMathExprLatex x ++ "^" ++ show n showMathExprLatex (NegativeAtom a) = "-" ++ a showMathExprLatex (Plus []) = "" showMathExprLatex (Plus (x:xs)) = showMathExprLatex x ++ showMathExprLatexForPlus xs where showMathExprLatexForPlus :: [MathExpr] -> String showMathExprLatexForPlus [] = "" - showMathExprLatexForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprLatexForPlus xs - showMathExprLatexForPlus ((Multiply (NegativeAtom "1":ys)):xs) = " - " ++ showMathExprLatex (Multiply ys) ++ showMathExprLatexForPlus xs - showMathExprLatexForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprLatex (Multiply ((Atom a []):ys)) ++ showMathExprLatexForPlus xs + showMathExprLatexForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprLatexForPlus xs + showMathExprLatexForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprLatex (Multiply ys) ++ showMathExprLatexForPlus xs + showMathExprLatexForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprLatex (Multiply (Atom a []:ys)) ++ showMathExprLatexForPlus xs showMathExprLatexForPlus (x:xs) = " + " ++ showMathExprLatex x ++ showMathExprLatexForPlus xs showMathExprLatex (Multiply []) = "" showMathExprLatex (Multiply [x]) = showMathExprLatex x @@ -144,9 +157,7 @@ showMathExprLatex (Func (Atom "rt" []) [x, y]) = "\\sqrt[" ++ showMathExprLatex x ++ "]{" ++ showMathExprLatex y ++ "}" showMathExprLatex (Func (Atom "/" []) [x, y]) = "\\frac{" ++ showMathExprLatex x ++ "}{" ++ showMathExprLatex y ++ "}" showMathExprLatex (Func f xs) = showMathExprLatex f ++ "(" ++ showMathExprLatexArg xs ", " ++ ")" -showMathExprLatex (Tensor xs mis) = case head xs of - Tensor _ _ -> "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis - _ -> "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis +showMathExprLatex (Tensor xs mis) = "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis showMathExprLatex (Tuple xs) = "(" ++ showMathExprLatexArg xs ", " ++ ")" showMathExprLatex (Collection xs) = "\\{" ++ showMathExprLatexArg xs ", " ++ "\\}" showMathExprLatex (Exp x) = "e^{" ++ showMathExprLatex x ++ "}" @@ -154,7 +165,7 @@ showMathExprLatex' :: MathExpr -> String showMathExprLatex' (Plus xs) = "(" ++ showMathExprLatex (Plus xs) ++ ")" -showMathExprLatex' x = showMathExprLatex x +showMathExprLatex' x = showMathExprLatex x showMathExprLatexArg :: [MathExpr] -> String -> String showMathExprLatexArg [] _ = "" @@ -163,17 +174,17 @@ showMathExprLatexSuper :: MathIndex -> String showMathExprLatexSuper (Super (Atom "#" [])) = "\\#" -showMathExprLatexSuper (Super x) = showMathExprLatex x -showMathExprLatexSuper (Sub x) = "\\;" +showMathExprLatexSuper (Super x) = showMathExprLatex x +showMathExprLatexSuper (Sub x) = "\\;" showMathExprLatexSub :: MathIndex -> String showMathExprLatexSub (Sub (Atom "#" [])) = "\\#" -showMathExprLatexSub (Sub x) = showMathExprLatex x -showMathExprLatexSub (Super x) = "\\;" +showMathExprLatexSub (Sub x) = showMathExprLatex x +showMathExprLatexSub (Super x) = "\\;" showMathExprLatexScript :: [MathIndex] -> String showMathExprLatexScript [] = "" -showMathExprLatexScript is = "_{" ++ concat (map showMathExprLatexSub is) ++ "}^{" ++ concat (map showMathExprLatexSuper is) ++ "}" +showMathExprLatexScript is = "_{" ++ concatMap showMathExprLatexSub is ++ "}^{" ++ concatMap showMathExprLatexSuper is ++ "}" showMathExprLatexVectors :: [MathExpr] -> String showMathExprLatexVectors [] = "" @@ -186,17 +197,16 @@ showMathExprMathematica :: MathExpr -> String showMathExprMathematica (Atom a []) = a ---showMathExprMathematica (Atom a xs) = a ++ showMathExprMathematicaScript xs -showMathExprMathematica (Partial f xs) = undefined +showMathExprMathematica (Partial f xs) = showMathExprMathematica f ++ "_" ++ (showMathExprsMathematica "_" xs) showMathExprMathematica (NegativeAtom a) = "-" ++ a showMathExprMathematica (Plus []) = "" showMathExprMathematica (Plus (x:xs)) = showMathExprMathematica x ++ showMathExprMathematicaForPlus xs where showMathExprMathematicaForPlus :: [MathExpr] -> String showMathExprMathematicaForPlus [] = "" - showMathExprMathematicaForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprMathematicaForPlus xs - showMathExprMathematicaForPlus ((Multiply (NegativeAtom "1":ys)):xs) = " - " ++ showMathExprMathematica (Multiply ys) ++ showMathExprMathematicaForPlus xs - showMathExprMathematicaForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprMathematica (Multiply ((Atom a []):ys)) ++ showMathExprMathematicaForPlus xs + showMathExprMathematicaForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprMathematicaForPlus xs + showMathExprMathematicaForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprMathematica (Multiply ys) ++ showMathExprMathematicaForPlus xs + showMathExprMathematicaForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprMathematica (Multiply (Atom a []:ys)) ++ showMathExprMathematicaForPlus xs showMathExprMathematicaForPlus (x:xs) = " + " ++ showMathExprMathematica x ++ showMathExprMathematicaForPlus xs showMathExprMathematica (Multiply []) = "" showMathExprMathematica (Multiply [x]) = showMathExprMathematica x @@ -206,7 +216,10 @@ showMathExprMathematica (Power lv1 lv2) = showMathExprMathematica lv1 ++ "^" ++ showMathExprMathematica lv2 showMathExprMathematica (Func (Atom "sqrt" []) [x]) = "Sqrt[" ++ showMathExprMathematica x ++ "]" showMathExprMathematica (Func (Atom "rt" []) [x, y]) = "Surd[" ++ showMathExprMathematica x ++ "," ++ showMathExprMathematica y ++ "]" -showMathExprMathematica (Func (Atom "/" []) [x, y]) = "(" ++ showMathExprMathematica x ++ ")/(" ++ showMathExprMathematica y ++ ")" +showMathExprMathematica (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y + where + addBracket x@(Atom _ []) = showMathExprMathematica x + addBracket x = "(" ++ showMathExprMathematica x ++ ")" showMathExprMathematica (Func f xs) = showMathExprMathematica f ++ "(" ++ showMathExprMathematicaArg xs ++ ")" showMathExprMathematica (Tensor lvs mis) | null mis = "{" ++ showMathExprMathematicaArg lvs ++ "}" @@ -222,10 +235,13 @@ showMathExprMathematica' (Plus xs) = "(" ++ showMathExprMathematica (Plus xs) ++ ")" showMathExprMathematica' x = showMathExprMathematica x +showMathExprsMathematica :: String -> [MathExpr] -> String +showMathExprsMathematica _ [] = "" +showMathExprsMathematica _ [a] = showMathExprMathematica a +showMathExprsMathematica s lvs = showMathExprMathematica (head lvs) ++ s ++ showMathExprsMathematica s (tail lvs) + showMathExprMathematicaArg :: [MathExpr] -> String -showMathExprMathematicaArg [] = "" -showMathExprMathematicaArg [a] = showMathExprMathematica a -showMathExprMathematicaArg lvs = showMathExprMathematica (head lvs) ++ ", " ++ (showMathExprMathematicaArg (tail lvs)) +showMathExprMathematicaArg xs = showMathExprsMathematica ", " xs showMathExprMathematicaIndices :: [MathIndex] -> String showMathExprMathematicaIndices [a] = showMathIndexMathematica a @@ -233,9 +249,55 @@ showMathIndexMathematica :: MathIndex -> String showMathIndexMathematica (Super a) = showMathExprMathematica a -showMathIndexMathematica (Sub a) = showMathExprMathematica a +showMathIndexMathematica (Sub a) = showMathExprMathematica a +-- +-- Show (Maxima) +-- +showMathExprMaxima :: MathExpr -> String +showMathExprMaxima (Atom a []) = a +showMathExprMaxima (Partial f xs) = "undefined" +showMathExprMaxima (NegativeAtom a) = "-" ++ a +showMathExprMaxima (Plus []) = "" +showMathExprMaxima (Plus (x:xs)) = showMathExprMaxima x ++ showMathExprMaximaForPlus xs + where + showMathExprMaximaForPlus :: [MathExpr] -> String + showMathExprMaximaForPlus [] = "" + showMathExprMaximaForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprMaximaForPlus xs + showMathExprMaximaForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprMaxima (Multiply ys) ++ showMathExprMaximaForPlus xs + showMathExprMaximaForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprMaxima (Multiply (Atom a []:ys)) ++ showMathExprMaximaForPlus xs + showMathExprMaximaForPlus (x:xs) = " + " ++ showMathExprMaxima x ++ showMathExprMaximaForPlus xs +showMathExprMaxima (Multiply []) = "" +showMathExprMaxima (Multiply [x]) = showMathExprMaxima x +showMathExprMaxima (Multiply (Atom "1" []:xs)) = showMathExprMaxima (Multiply xs) +showMathExprMaxima (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExprMaxima (Multiply xs) +showMathExprMaxima (Multiply (x:xs)) = showMathExprMaxima' x ++ " * " ++ showMathExprMaxima (Multiply xs) +showMathExprMaxima (Power lv1 lv2) = showMathExprMaxima lv1 ++ "^" ++ showMathExprMaxima lv2 +showMathExprMaxima (Func (Atom "sqrt" []) [x]) = "sqrt(" ++ showMathExprMaxima x ++ ")" +showMathExprMaxima (Func (Atom "rt" []) [x, y]) = showMathExprMaxima y ++ "^(1/" ++ showMathExprMaxima x ++ ")" +showMathExprMaxima (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y + where + addBracket x@(Atom _ []) = showMathExprMaxima x + addBracket x = "(" ++ showMathExprMaxima x ++ ")" +showMathExprMaxima (Func f xs) = showMathExprMaxima f ++ "(" ++ showMathExprMaximaArg xs ++ ")" +showMathExprMaxima (Tensor lvs mis) = "undefined" +showMathExprMaxima (Tuple xs) = "undefined" +showMathExprMaxima (Collection xs) = "[" ++ showMathExprMaximaArg xs ++ "]" +showMathExprMaxima (Exp x) = "exp(" ++ showMathExprMaxima x ++ ")" +showMathExprMaxima (Quote x) = "(" ++ showMathExprMaxima x ++ ")" + +showMathExprMaxima' :: MathExpr -> String +showMathExprMaxima' (Plus xs) = "(" ++ showMathExprMaxima (Plus xs) ++ ")" +showMathExprMaxima' x = showMathExprMaxima x + +showMathExprMaximaArg :: [MathExpr] -> String +showMathExprMaximaArg [] = "" +showMathExprMaximaArg [Tensor lvs []] = "undefined" +showMathExprMaximaArg [a] = showMathExprMaxima a +showMathExprMaximaArg lvs = showMathExprMaxima (head lvs) ++ ", " ++ showMathExprMaximaArg (tail lvs) + + -- -- Parser -- @@ -250,102 +312,47 @@ symbol = oneOf "!$%&*+-/:<=>?@#" parseAtom :: Parser MathExpr -parseAtom = do - first <- letter <|> symbol <|> digit - rest <- many (letter <|> digit <|> symbol) - let atom = first : rest - ys <- many parseScript - return $ Atom atom ys +parseAtom = Atom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol)) <*> many parseScript parseAtom' :: Parser MathExpr -parseAtom' = do - first <- letter <|> symbol <|> digit - rest <- many (letter <|> digit <|> symbol) - let atom = first : rest - return $ Atom atom [] +parseAtom' = flip Atom [] <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol)) parsePartial :: Parser MathExpr -parsePartial = do - xs <- parseAtom - is <- many1 (char '|' >> parseAtom) - return $ Partial xs is +parsePartial = Partial <$> parseAtom <*> many1 (char '|' >> parseAtom) parseNegativeAtom :: Parser MathExpr -parseNegativeAtom = do - char '-' - first <- letter <|> symbol <|> digit - rest <- many (letter <|> digit <|> symbol) - let atom = first : rest - return $ NegativeAtom atom +parseNegativeAtom = char '-' >> NegativeAtom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol)) parseList :: Parser [MathExpr] parseList = sepEndBy parseExpr spaces parseScript :: Parser MathIndex -parseScript = (Sub <$> (char '_' >> parseAtom')) <|> (Super <$> (char '~' >> parseAtom')) +parseScript = Sub <$> (char '_' >> parseAtom') + <|> Super <$> (char '~' >> parseAtom') parsePlus :: Parser MathExpr -parsePlus = do - string "(+" - spaces - xs <- parseList - char ')' - return $ Plus xs +parsePlus = string "(+" >> spaces >> Plus <$> parseList <* char ')' parseMultiply :: Parser MathExpr -parseMultiply = do - string "(*" - spaces - xs <- parseList - char ')' - return $ Multiply xs +parseMultiply = string "(*" >> spaces >> Multiply <$> parseList <* char ')' parseFunction :: Parser MathExpr -parseFunction = do - char '(' - func <- parseAtom - spaces - xs <- parseList - char ')' - return $ Func func xs +parseFunction = char '(' >> Func <$> parseAtom <* spaces <*> parseList <* char ')' parseTensor :: Parser MathExpr -parseTensor = do - string "[|" - spaces0 - xs <- parseList - spaces0 - string "|]" - ys <- many parseScript - return $ Tensor xs ys +parseTensor = string "[|" >> spaces0 >> Tensor <$> parseList <* spaces0 <* string "|]" <*> many parseScript parseTuple :: Parser MathExpr -parseTuple = do - char '[' - xs <- parseList - char ']' - return $ Tuple xs +parseTuple = char '[' >> Tuple <$> parseList <* char ']' parseCollection :: Parser MathExpr -parseCollection = do - char '{' - xs <- parseList - char '}' - return $ Collection xs +parseCollection = char '{' >> Collection <$> parseList <* char '}' parseExp :: Parser MathExpr -parseExp = do - string "(exp" - spaces - x <- parseExpr - char ')' - return $ Exp x +parseExp = string "(exp" >> spaces >> Exp <$> parseExpr <* char ')' parseQuote :: Parser MathExpr -parseQuote = do - char '\'' - x <- parseExpr' - return $ Quote x +parseQuote = char '\'' >> Quote <$> parseExpr' parseExpr' :: Parser MathExpr parseExpr' = parseNegativeAtom @@ -362,9 +369,9 @@ parseExpr :: Parser MathExpr parseExpr = do - x <- parseExpr' - option x $ Power x <$> try (char '^' >> parseExpr') + x <- parseExpr' + option x $ Power x <$> try (char '^' >> parseExpr') elemCount :: Eq a => [a] -> [(a, Int)] elemCount [] = [] -elemCount (x:xs) = (x, (length $ filter (== x) xs) + 1) : elemCount (filter (/= x) xs) +elemCount (x:xs) = (x, length (filter (== x) xs) + 1) : elemCount (filter (/= x) xs) diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TupleSections, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} {- | Module : Language.Egison.Parser @@ -24,32 +25,33 @@ , loadFile ) where -import Prelude hiding (mapM) -import Control.Monad.Identity hiding (mapM) -import Control.Monad.Except hiding (mapM) -import Control.Monad.State hiding (mapM) -import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) +import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) +import Control.Monad.Except hiding (mapM) +import Control.Monad.Identity hiding (mapM) +import Control.Monad.State hiding (mapM) +import Prelude hiding (mapM) -import System.Directory (doesFileExist, getHomeDirectory) +import System.Directory (doesFileExist, getHomeDirectory) -import qualified Data.Sequence as Sq -import Data.Either -import Data.Char (isLower, isUpper) -import qualified Data.Set as Set -import Data.Traversable (mapM) -import Data.Ratio -import Data.List.Split (splitOn) +import Data.Char (isLower, isUpper) +import Data.Either +import Data.Functor (($>)) +import Data.List.Split (splitOn) +import Data.Ratio +import qualified Data.Sequence as Sq +import qualified Data.Set as Set +import Data.Traversable (mapM) -import Text.Parsec -import Text.Parsec.String -import qualified Text.Parsec.Token as P +import Text.Parsec +import Text.Parsec.String +import qualified Text.Parsec.Token as P -import qualified Data.Text as T -import Text.Regex.TDFA +import qualified Data.Text as T +import Text.Regex.TDFA -import Language.Egison.Types -import Language.Egison.Desugar -import Paths_egison (getDataFileName) +import Language.Egison.Desugar +import Language.Egison.Types +import Paths_egison (getDataFileName) readTopExprs :: String -> EgisonM [EgisonTopExpr] readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs @@ -90,7 +92,7 @@ -- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] loadLibraryFile file = do - homeDir <- liftIO $ getHomeDirectory + homeDir <- liftIO getHomeDirectory doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file if doesExist then loadFile $ homeDir ++ "/.egison/" ++ file @@ -105,12 +107,12 @@ exprs <- readTopExprs $ shebang input concat <$> mapM recursiveLoad exprs where - recursiveLoad (Load _ file) = loadLibraryFile file + recursiveLoad (Load _ file) = loadLibraryFile file recursiveLoad (LoadFile _ file) = loadFile file - recursiveLoad expr = return [expr] + recursiveLoad expr = return [expr] shebang :: String -> String shebang ('#':'!':cs) = ';':'#':'!':cs - shebang cs = cs + shebang cs = cs -- -- Parser @@ -142,15 +144,14 @@ defineExpr :: Parser EgisonTopExpr defineExpr = try (parens (keywordDefine >> Define <$> (char '$' >> identVar) <*> expr)) <|> try (parens (do keywordDefine - (VarWithIndices name is) <- (char '$' >> identVarWithIndices) - body <- expr - return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) body)))) + (VarWithIndices name is) <- char '$' >> identVarWithIndices + Define (Var name (map f is)) . WithSymbolsExpr (map g is) . TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) <$> expr)) where - f (Superscript _) = Superscript () - f (Subscript _) = Subscript () + f (Superscript _) = Superscript () + f (Subscript _) = Subscript () f (SupSubscript _) = SupSubscript () - g (Superscript i) = i - g (Subscript i) = i + g (Superscript i) = i + g (Subscript i) = i g (SupSubscript i) = i redefineExpr :: Parser EgisonTopExpr @@ -175,87 +176,85 @@ expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr' expr1 <- option expr0 $ try (string "..." >> IndexedExpr False expr0 <$> parseindex) <|> IndexedExpr True expr0 <$> parseindex - option expr1 $ PowerExpr expr1 <$> (try $ char '^' >> expr')) + option expr1 $ PowerExpr expr1 <$> try (char '^' >> expr')) where parseindex :: Parser [Index EgisonExpr] parseindex = many1 (try (do char '_' e1 <- expr' string "..._" - e2 <- expr' - return $ MultiSubscript e1 e2) + MultiSubscript e1 <$> expr') <|> try (do char '~' e1 <- expr' string "...~" - e2 <- expr' - return $ MultiSuperscript e1 e2) - <|> try (char '_' >> expr' >>= return . Subscript) - <|> try (char '~' >> expr' >>= return . Superscript) - <|> try (string "~_" >> expr' >>= return . SupSubscript) - <|> try (char '|' >> expr' >>= return . Userscript)) + MultiSuperscript e1 <$> expr') + <|> try (Subscript <$> (char '_' >> expr')) + <|> try (Superscript <$> (char '~' >> expr')) + <|> try (SupSubscript <$> (string "~_" >> expr')) + <|> try (Userscript <$> (char '|' >> expr'))) quoteExpr' :: Parser EgisonExpr quoteExpr' = char '\'' >> QuoteExpr <$> expr' expr' :: Parser EgisonExpr -expr' = (try partialExpr - <|> try constantExpr - <|> try partialVarExpr - <|> try freshVarExpr - <|> try varExpr - <|> inductiveDataExpr - <|> try arrayExpr - <|> try vectorExpr - <|> try tupleExpr - <|> try hashExpr - <|> collectionExpr --- <|> quoteExpr - <|> quoteSymbolExpr - <|> wedgeExpr - <|> parens (ifExpr - <|> lambdaExpr - <|> memoizedLambdaExpr - <|> memoizeExpr - <|> cambdaExpr - <|> procedureExpr - <|> macroExpr - <|> patternFunctionExpr - <|> letRecExpr - <|> letExpr - <|> letStarExpr - <|> withSymbolsExpr - <|> doExpr - <|> ioExpr - <|> matchAllExpr - <|> matchExpr - <|> matchAllLambdaExpr - <|> matchLambdaExpr - <|> matcherExpr - <|> matcherDFSExpr - <|> seqExpr - <|> applyExpr - <|> cApplyExpr - <|> algebraicDataMatcherExpr - <|> generateArrayExpr - <|> arrayBoundsExpr - <|> arrayRefExpr - <|> generateTensorExpr - <|> symbolicTensorExpr - <|> tensorExpr - <|> tensorContractExpr - <|> tensorMapExpr - <|> tensorMap2Expr - <|> transposeExpr - <|> parExpr - <|> pseqExpr - <|> pmapExpr - <|> subrefsExpr - <|> suprefsExpr - <|> userrefsExpr - <|> functionWithArgExpr - ) - "expression") +expr' = try partialExpr + <|> try constantExpr + <|> try partialVarExpr + <|> try freshVarExpr + <|> try varExpr + <|> inductiveDataExpr + <|> try arrayExpr + <|> try vectorExpr + <|> try tupleExpr + <|> try hashExpr + <|> collectionExpr +-- <|> quoteExpr + <|> quoteSymbolExpr + <|> wedgeExpr + <|> parens (ifExpr + <|> lambdaExpr + <|> memoizedLambdaExpr + <|> memoizeExpr + <|> cambdaExpr + <|> procedureExpr + <|> macroExpr + <|> patternFunctionExpr + <|> letRecExpr + <|> letExpr + <|> letStarExpr + <|> withSymbolsExpr + <|> doExpr + <|> ioExpr + <|> matchAllExpr + <|> matchAllDFSExpr + <|> matchExpr + <|> matchAllLambdaExpr + <|> matchLambdaExpr + <|> matcherExpr + <|> seqExpr + <|> applyExpr + <|> cApplyExpr + <|> algebraicDataMatcherExpr + <|> generateArrayExpr + <|> arrayBoundsExpr + <|> arrayRefExpr + <|> generateTensorExpr + <|> symbolicTensorExpr + <|> tensorExpr + <|> tensorContractExpr + <|> tensorMapExpr + <|> tensorMap2Expr + <|> transposeExpr + <|> parExpr + <|> pseqExpr + <|> pmapExpr + <|> subrefsExpr + <|> suprefsExpr + <|> userrefsExpr + <|> functionWithArgExpr + ) + "expression" varExpr :: Parser EgisonExpr varExpr = VarExpr <$> identVarWithoutIndex @@ -303,25 +302,28 @@ wedgeExpr = char '!' >> WedgeExpr <$> expr functionWithArgExpr :: Parser EgisonExpr -functionWithArgExpr = keywordFunction >> FunctionExpr <$> (between lp rp $ sepEndBy expr whiteSpace) +functionWithArgExpr = keywordFunction >> FunctionExpr <$> between lp rp (sepEndBy expr whiteSpace) where lp = P.lexeme lexer (char '[') rp = char ']' symbolicTensorExpr :: Parser EgisonExpr -symbolicTensorExpr = keywordSymbolicTensor >> SymbolicTensorExpr <$> (brackets $ sepEndBy expr whiteSpace) <*> expr <*> ident +symbolicTensorExpr = keywordSymbolicTensor >> SymbolicTensorExpr <$> brackets (sepEndBy expr whiteSpace) <*> expr <*> ident quoteSymbolExpr :: Parser EgisonExpr quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr matchAllExpr :: Parser EgisonExpr -matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses) +matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses) +matchAllDFSExpr :: Parser EgisonExpr +matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses) + matchExpr :: Parser EgisonExpr matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses matchAllLambdaExpr :: Parser EgisonExpr -matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses) +matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses) matchLambdaExpr :: Parser EgisonExpr matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses @@ -335,9 +337,6 @@ matcherExpr :: Parser EgisonExpr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses -matcherDFSExpr :: Parser EgisonExpr -matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses - ppMatchClauses :: Parser MatcherInfo ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace @@ -358,10 +357,10 @@ "primitive-pattren-pattern") ppWildCard :: Parser PrimitivePatPattern -ppWildCard = reservedOp "_" *> pure PPWildCard +ppWildCard = reservedOp "_" $> PPWildCard ppPatVar :: Parser PrimitivePatPattern -ppPatVar = reservedOp "$" *> pure PPPatVar +ppPatVar = reservedOp "$" $> PPPatVar ppValuePat :: Parser PrimitivePatPattern ppValuePat = reservedOp ",$" >> PPValuePat <$> ident @@ -370,10 +369,10 @@ ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace) pdPattern :: Parser PrimitiveDataPattern -pdPattern = P.lexeme lexer $ pdPattern' +pdPattern = P.lexeme lexer pdPattern' pdPattern' :: Parser PrimitiveDataPattern -pdPattern' = reservedOp "_" *> pure PDWildCard +pdPattern' = reservedOp "_" $> PDWildCard <|> (char '$' >> PDPatVar <$> ident) <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern)) <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern) @@ -423,7 +422,7 @@ letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr withSymbolsExpr :: Parser EgisonExpr -withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> (braces $ sepEndBy ident whiteSpace) <*> expr +withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident whiteSpace) <*> expr doExpr :: Parser EgisonExpr doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr $ stringToVar "return") (TupleExpr [])) expr @@ -455,9 +454,9 @@ <|> brackets (sepEndBy argName whiteSpace) argName :: Parser Arg -argName = try (char '$' >> ident >>= return . ScalarArg) - <|> try (string "*$" >> ident >>= return . InvertedScalarArg) - <|> try (char '%' >> ident >>= return . TensorArg) +argName = try (ScalarArg <$> (char '$' >> ident)) + <|> try (InvertedScalarArg <$> (string "*$" >> ident)) + <|> try (TensorArg <$> (char '%' >> ident)) ioExpr :: Parser EgisonExpr ioExpr = keywordIo >> IoExpr <$> expr @@ -466,7 +465,7 @@ seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr cApplyExpr :: Parser EgisonExpr -cApplyExpr = (keywordCApply >> CApplyExpr <$> expr <*> expr) +cApplyExpr = keywordCApply >> CApplyExpr <$> expr <*> expr applyExpr :: Parser EgisonExpr applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr) @@ -481,8 +480,8 @@ [] -> return . ApplyExpr func . TupleExpr $ rights args _ | all null vars -> let args' = rights args - args'' = map f (zip args (annonVars 1 (length args))) - args''' = map (VarExpr . stringToVar . (either id id)) args'' + args'' = zipWith (curry f) args (annonVars 1 (length args)) + args''' = map (VarExpr . stringToVar . either id id) args'' in return $ ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args' | all (not . null) vars -> let ns = Set.fromList $ map read vars @@ -490,8 +489,8 @@ in if Set.findMin ns == 1 && Set.findMax ns == n then let args' = rights args - args'' = map g (zip args (annonVars (n + 1) (length args))) - args''' = map (VarExpr . stringToVar . (either id id)) args'' + args'' = zipWith (curry g) args (annonVars (n + 1) (length args)) + args''' = map (VarExpr . stringToVar . either id id) args'' in return $ ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args' else fail "invalid partial application" | otherwise -> fail "invalid partial application" @@ -501,13 +500,13 @@ <|> char '$' *> (Left <$> option "" index) index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit annonVars m n = take n $ map ((':':) . show) [m..] - f ((Left _), var) = Left var - f ((Right _), var) = Right var - g ((Left arg), _) = Left (':':arg) - g ((Right _), var) = Right var + f (Left _, var) = Left var + f (Right _, var) = Right var + g (Left arg, _) = Left (':':arg) + g (Right _, var) = Right var partialExpr :: Parser EgisonExpr -partialExpr = PartialExpr <$> read <$> index <*> (char '#' >> expr) +partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> expr) where index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit @@ -588,15 +587,16 @@ <|> notPat <|> tuplePat <|> inductivePat + <|> laterPatVar + <|> try seqNilPat + <|> try seqConsPat + <|> try seqPat <|> parens (andPat <|> notPat' - <|> orderedOrPat <|> orPat <|> loopPat <|> letPat <|> laterPat - <|> bfsPat - <|> dfsPat <|> try divPat <|> try plusPat <|> try multPat @@ -651,9 +651,6 @@ orPat :: Parser EgisonPattern orPat = (reservedOp "|" <|> keywordOr) >> OrPat <$> sepEndBy pattern whiteSpace -orderedOrPat :: Parser EgisonPattern -orderedOrPat = reservedOp "|*" >> OrderedOrPat' <$> sepEndBy pattern whiteSpace - pApplyPat :: Parser EgisonPattern pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace @@ -667,8 +664,23 @@ loopRange = brackets (try (LoopRange <$> expr <*> expr <*> option WildCard pattern) <|> (do s <- expr ep <- option WildCard pattern - return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep))) + return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, IntegerExpr 1]))) ep))) +seqNilPat :: Parser EgisonPattern +seqNilPat = braces $ pure SeqNilPat + +seqConsPat :: Parser EgisonPattern +seqConsPat = braces $ SeqConsPat <$> pattern <*> (char '@' >> pattern) + +seqPat :: Parser EgisonPattern +seqPat = braces $ do + pats <- sepEndBy pattern whiteSpace + tailPat <- option SeqNilPat (char '@' >> pattern) + return $ foldr (\p rets -> SeqConsPat p rets) tailPat pats + +laterPatVar :: Parser EgisonPattern +laterPatVar = char '#' >> pure LaterPatVar + divPat :: Parser EgisonPattern divPat = reservedOp "/" >> DivPat <$> pattern <*> pattern @@ -682,12 +694,6 @@ powerPat = try (PowerPat <$> pattern <* char '^' <*> pattern) <|> pattern -dfsPat :: Parser EgisonPattern -dfsPat = keywordDFS >> DFSPat' <$> pattern - -bfsPat :: Parser EgisonPattern -bfsPat = keywordBFS >> BFSPat <$> pattern - -- Constants constantExpr :: Parser EgisonExpr @@ -696,8 +702,8 @@ <|> try charExpr <|> try floatExpr <|> try integerExpr - <|> (keywordSomething *> pure SomethingExpr) - <|> (keywordUndefined *> pure UndefinedExpr) + <|> (keywordSomething $> SomethingExpr) + <|> (keywordUndefined $> UndefinedExpr) "constant" charExpr :: Parser EgisonExpr @@ -713,13 +719,11 @@ floatExpr = do (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i') <|> try ((,) 0 <$> floatLiteral' <* char 'i') - <|> try (flip (,) 0 <$> floatLiteral') + <|> try ((, 0) <$> floatLiteral') return $ FloatExpr x y integerExpr :: Parser EgisonExpr -integerExpr = do - n <- integerLiteral' - return $ IntegerExpr n +integerExpr = IntegerExpr <$> integerLiteral' integerLiteral' :: Parser Integer integerLiteral' = sign <*> positiveIntegerLiteral @@ -733,8 +737,8 @@ char '.' mStr <- many1 digit let m = read mStr - let l = m % (10 ^ (fromIntegral (length mStr))) - return (fromRational ((fromIntegral n) + l) :: Double) + let l = m % (10 ^ fromIntegral (length mStr)) + return (fromRational (fromIntegral n + l) :: Double) floatLiteral' :: Parser Double floatLiteral' = sign <*> positiveFloatLiteral @@ -875,11 +879,11 @@ keywordLoop = reserved "loop" keywordCont = reserved "..." keywordMatchAll = reserved "match-all" +keywordMatchAllDFS = reserved "match-all-dfs" keywordMatchAllLambda = reserved "match-all-lambda" keywordMatch = reserved "match" keywordMatchLambda = reserved "match-lambda" keywordMatcher = reserved "matcher" -keywordMatcherDFS = reserved "matcher-dfs" keywordDo = reserved "do" keywordIo = reserved "io" keywordSomething = reserved "something" @@ -905,8 +909,6 @@ keywordUserrefsNew = reserved "user-refs!" keywordFunction = reserved "function" keywordSymbolicTensor = reserved "symbolic-tensor" -keywordDFS = reserved "dfs" -keywordBFS = reserved "bfs" sign :: Num a => Parser (a -> a) sign = (char '-' >> return negate) @@ -939,7 +941,7 @@ return $ doParse' charLiteral $ "'" ++ x ++ "'" boolLiteral :: Parser Bool -boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False) +boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False) whiteSpace :: Parser () whiteSpace = P.whiteSpace lexer @@ -975,9 +977,7 @@ return $ Var (splitOn "." name) is) identVarWithoutIndex :: Parser Var -identVarWithoutIndex = do - x <- ident - return $ stringToVar x +identVarWithoutIndex = stringToVar <$> ident identVarWithIndices :: Parser VarWithIndices identVarWithIndices = P.lexeme lexer (do @@ -994,7 +994,7 @@ <|> try (char '_' >> return (Subscript ())) upperName :: Parser String -upperName = P.lexeme lexer $ upperName' +upperName = P.lexeme lexer upperName' upperName' :: Parser String upperName' = (:) <$> upper <*> option "" ident @@ -1003,7 +1003,7 @@ upper = satisfy isUpper lowerName :: Parser String -lowerName = P.lexeme lexer $ lowerName' +lowerName = P.lexeme lexer lowerName' lowerName' :: Parser String lowerName' = (:) <$> lower <*> option "" ident diff --git a/hs-src/Language/Egison/ParserNonS.hs b/hs-src/Language/Egison/ParserNonS.hs --- a/hs-src/Language/Egison/ParserNonS.hs +++ b/hs-src/Language/Egison/ParserNonS.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TupleSections, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} {- | Module : Language.Egison.ParserNonS @@ -24,34 +25,35 @@ , loadFile ) where -import Prelude hiding (mapM) -import Control.Monad.Identity hiding (mapM) -import Control.Monad.Except hiding (mapM) -import Control.Monad.State hiding (mapM) -import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) +import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) +import Control.Monad.Except hiding (mapM) +import Control.Monad.Identity hiding (mapM) +import Control.Monad.State hiding (mapM) +import Prelude hiding (mapM) -import System.Directory (doesFileExist, getHomeDirectory) +import System.Directory (doesFileExist, getHomeDirectory) -import qualified Data.Sequence as Sq -import Data.Either -import Data.Char (isLower, isUpper, toLower) -import qualified Data.Set as Set -import Data.Traversable (mapM) -import Data.Ratio -import Data.List (intercalate) -import Data.List.Split (split, splitOn, startsWithOneOf) +import Data.Char (isLower, isUpper, toLower) +import Data.Either +import Data.Functor (($>)) +import Data.List (intercalate) +import Data.List.Split (split, splitOn, startsWithOneOf) +import Data.Ratio +import qualified Data.Sequence as Sq +import qualified Data.Set as Set +import Data.Traversable (mapM) -import Text.Parsec -import Text.Parsec.String -import Text.Parsec.Expr -import qualified Text.Parsec.Token as P +import Text.Parsec +import Text.Parsec.Expr +import Text.Parsec.String +import qualified Text.Parsec.Token as P -import qualified Data.Text as T -import Text.Regex.TDFA +import qualified Data.Text as T +import Text.Regex.TDFA -import Language.Egison.Types -import Language.Egison.Desugar -import Paths_egison (getDataFileName) +import Language.Egison.Desugar +import Language.Egison.Types +import Paths_egison (getDataFileName) readTopExprs :: String -> EgisonM [EgisonTopExpr] readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs @@ -92,7 +94,7 @@ -- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] loadLibraryFile file = do - homeDir <- liftIO $ getHomeDirectory + homeDir <- liftIO getHomeDirectory doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file if doesExist then loadFile $ homeDir ++ "/.egison/" ++ file @@ -107,12 +109,12 @@ exprs <- readTopExprs $ shebang input concat <$> mapM recursiveLoad exprs where - recursiveLoad (Load _ file) = loadLibraryFile file + recursiveLoad (Load _ file) = loadLibraryFile file recursiveLoad (LoadFile _ file) = loadFile file - recursiveLoad expr = return [expr] + recursiveLoad expr = return [expr] shebang :: String -> String shebang ('#':'!':cs) = ';':'#':'!':cs - shebang cs = cs + shebang cs = cs -- -- Parser @@ -141,24 +143,23 @@ "top-level expression" defineExpr :: Parser EgisonTopExpr -defineExpr = try (Define <$> identVar <*> (LambdaExpr <$> (parens argNames') <* (inSpaces $ string "=") <* notFollowedBy (string "=") <*> expr)) - <|> try (Define <$> identVar <* (inSpaces $ string "=") <* notFollowedBy (string "=") <*> expr) +defineExpr = try (Define <$ keywordDefine <*> identVar <*> (LambdaExpr <$> parens argNames' <* inSpaces (reservedOp "=") <* notFollowedBy (string "=") <*> expr)) + <|> try (Define <$> identVar <* inSpaces (reservedOp "=") <* notFollowedBy (string "=") <*> expr) <|> try (do (VarWithIndices name is) <- identVarWithIndices - inSpaces $ string "=" >> notFollowedBy (string "=") - body <- expr - return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) body))) + inSpaces $ reservedOp "=" >> notFollowedBy (string "=") + Define (Var name (map f is)) . WithSymbolsExpr (map g is) . TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) <$> expr) where argNames' :: Parser [Arg] argNames' = sepEndBy argName' comma argName' :: Parser Arg - argName' = try (ident >>= return . ScalarArg) - <|> try (char '*' >> ident >>= return . InvertedScalarArg) - <|> try (char '%' >> ident >>= return . TensorArg) - f (Superscript _) = Superscript () - f (Subscript _) = Subscript () + argName' = try (ScalarArg <$> ident) + <|> try (InvertedScalarArg <$> (char '*' >> ident)) + <|> try (TensorArg <$> (char '%' >> ident)) + f (Superscript _) = Superscript () + f (Subscript _) = Subscript () f (SupSubscript _) = SupSubscript () - g (Superscript i) = i - g (Subscript i) = i + g (Superscript i) = i + g (Subscript i) = i g (SupSubscript i) = i testExpr :: Parser EgisonTopExpr @@ -194,12 +195,12 @@ , [binary "&&" "and" AssocLeft, binary "||" "or" AssocLeft] , [binary "++" "join" AssocRight] ] - unary "-" assoc = Prefix (try $ inSpaces (string "-") >> (return $ \x -> (makeApply (VarExpr $ stringToVar "*") [IntegerExpr (-1), x]))) - unary op assoc = Prefix (try $ inSpaces (string op) >> (return $ \x -> makeApply (VarExpr $ stringToVar op) [x])) + unary "-" assoc = Prefix (try $ inSpaces (string "-") >> return (\x -> makeApply (VarExpr $ stringToVar "*") [IntegerExpr (-1), x])) + unary op assoc = Prefix (try $ inSpaces (string op) >> return (\x -> makeApply (VarExpr $ stringToVar op) [x])) binary op name assoc - | op == "/" = Infix (try $ (try (inSpaces1 $ string op) <|> ((inSpaces $ string op) >> notFollowedBy (string "m" <|> string "fn"))) >> (return $ \x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc - | (op == "." || op == "%") = Infix (try $ (inSpaces1 $ string op) >> (return $ \x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc - | otherwise = Infix (try $ inSpaces (string op) >> (return $ \x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc + | op == "/" = Infix (try $ (try (inSpaces1 $ string op) <|> (inSpaces (string op) >> notFollowedBy (string "m" <|> string "fn"))) >> return (\x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc + | op == "." || op == "%" = Infix (try $ inSpaces1 (string op) >> return (\x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc + | otherwise = Infix (try $ inSpaces (string op) >> return (\x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc inSpaces :: Parser a -> Parser () inSpaces p = skipMany (space <|> newline) >> p >> skipMany (space <|> newline) @@ -230,10 +231,10 @@ term' :: Parser EgisonExpr term' = matchExpr <|> matchAllExpr + <|> matchAllDFSExpr <|> matchLambdaExpr <|> matchAllLambdaExpr <|> matcherExpr - <|> matcherDFSExpr <|> functionWithArgExpr <|> userrefsExpr <|> algebraicDataMatcherExpr @@ -314,7 +315,7 @@ wedgeExpr = char '!' >> WedgeExpr <$> expr functionWithArgExpr :: Parser EgisonExpr -functionWithArgExpr = keywordFunction >> FunctionExpr <$> (parens $ sepEndBy expr comma) +functionWithArgExpr = keywordFunction >> FunctionExpr <$> parens (sepEndBy expr comma) quoteSymbolExpr :: Parser EgisonExpr quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr @@ -322,6 +323,9 @@ matchAllExpr :: Parser EgisonExpr matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* keywordAs <*> expr <*> matchClauses +matchAllDFSExpr :: Parser EgisonExpr +matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <* keywordAs <*> expr <*> matchClauses + matchExpr :: Parser EgisonExpr matchExpr = keywordMatch >> MatchExpr <$> expr <* keywordAs <*> expr <*> matchClauses @@ -335,25 +339,22 @@ matchClauses = many1 matchClause matchClause :: Parser MatchClause -matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* (reservedOp "->") <*> expr +matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* reservedOp "->" <*> expr matcherExpr :: Parser EgisonExpr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses -matcherDFSExpr :: Parser EgisonExpr -matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses - ppMatchClauses :: Parser MatcherInfo ppMatchClauses = many1 ppMatchClause ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) -ppMatchClause = inSpaces (string "|") >> (,,) <$> ppPattern <* keywordAs <*> expr <* (reservedOp "->") <*> pdMatchClauses +ppMatchClause = inSpaces (string "|") >> (,,) <$> ppPattern <* keywordAs <*> expr <* reservedOp "->" <*> pdMatchClauses pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)] pdMatchClauses = many1 pdMatchClause pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr) -pdMatchClause = try $ inSpaces (string "|") >> (,) <$> pdPattern <* (reservedOp "->") <*> expr +pdMatchClause = try $ inSpaces (string "|") >> (,) <$> pdPattern <* reservedOp "->" <*> expr ppPattern :: Parser PrimitivePatPattern ppPattern = P.lexeme lexer (ppWildCard @@ -363,10 +364,10 @@ "primitive-pattren-pattern") ppWildCard :: Parser PrimitivePatPattern -ppWildCard = reservedOp "_" *> pure PPWildCard +ppWildCard = reservedOp "_" $> PPWildCard ppPatVar :: Parser PrimitivePatPattern -ppPatVar = reservedOp "$" *> pure PPPatVar +ppPatVar = reservedOp "$" $> PPPatVar ppValuePat :: Parser PrimitivePatPattern ppValuePat = reservedOp "$" >> PPValuePat <$> ident @@ -378,7 +379,7 @@ pdPattern = P.lexeme lexer pdPattern' pdPattern' :: Parser PrimitiveDataPattern -pdPattern' = reservedOp "_" *> pure PDWildCard +pdPattern' = reservedOp "_" $> PDWildCard <|> (char '$' >> PDPatVar <$> ident) <|> brackets ((PDConsPat <$> pdPattern <* comma <*> (char '@' *> pdPattern)) <|> (PDSnocPat <$> (char '@' *> pdPattern) <* comma <*> pdPattern) @@ -413,7 +414,7 @@ macroExpr = keywordMacro >> MacroExpr <$> varNames <* reservedOp "->" <*> expr patternFunctionExpr :: Parser EgisonExpr -patternFunctionExpr = keywordPatternFunction >> parens (PatternFunctionExpr <$> (brackets $ sepEndBy ident comma) <* comma <*> pattern) +patternFunctionExpr = keywordPatternFunction >> parens (PatternFunctionExpr <$> brackets (sepEndBy ident comma) <* comma <*> pattern) letRecExpr :: Parser EgisonExpr letRecExpr = keywordLetRec >> LetRecExpr <$> bindings <* keywordLetIn <*> expr @@ -425,7 +426,7 @@ letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <* keywordLetIn <*> expr withSymbolsExpr :: Parser EgisonExpr -withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> (braces $ sepEndBy ident comma) <*> expr +withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident comma) <*> expr doExpr :: Parser EgisonExpr doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr $ stringToVar "return") (TupleExpr [])) expr @@ -454,9 +455,9 @@ argNames = sepEndBy argName whiteSpace argName :: Parser Arg -argName = try (char '$' >> ident >>= return . ScalarArg) - <|> try (string "*$" >> ident >>= return . InvertedScalarArg) - <|> try (char '%' >> ident >>= return . TensorArg) +argName = try (ScalarArg <$> (char '$' >> ident)) + <|> try (InvertedScalarArg <$> (string "*$" >> ident)) + <|> try (TensorArg <$> (char '%' >> ident)) ioExpr :: Parser EgisonExpr ioExpr = keywordIo >> parens (IoExpr <$> expr) @@ -473,15 +474,15 @@ applyExpr' :: Parser EgisonExpr applyExpr' = do - func <- try varExpr <|> try partialExpr <|> try partialVarExpr <|> (parens expr) + func <- try varExpr <|> try partialExpr <|> try partialVarExpr <|> parens expr applyExpr'' func applyExpr'' :: EgisonExpr -> Parser EgisonExpr applyExpr'' func = do argslist <- many1 $ parens args - return $ foldl (\acc xs -> makeApply acc xs) func argslist + return $ foldl makeApply func argslist where - args = sepEndBy arg $ comma + args = sepEndBy arg comma arg = try expr <|> char '$' *> (LambdaArgExpr <$> option "" index) index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit @@ -490,7 +491,7 @@ applyInfixExpr = do arg1 <- arg spaces - func <- (char '`' *> varExpr <* char '`') + func <- char '`' *> varExpr <* char '`' spaces arg2 <- arg return $ makeApply func [arg1, arg2] @@ -503,30 +504,30 @@ makeApply func xs = do let args = map (\x -> case x of LambdaArgExpr s -> Left s - _ -> Right x) xs + _ -> Right x) xs let vars = lefts args case vars of [] -> ApplyExpr func . TupleExpr $ rights args _ | all null vars -> let args' = rights args - args'' = map f (zip args (annonVars 1 (length args))) - args''' = map (VarExpr . stringToVar . (either id id)) args'' + args'' = zipWith (curry f) args (annonVars 1 (length args)) + args''' = map (VarExpr . stringToVar . either id id) args'' in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args' | all (not . null) vars -> let n = Set.size $ Set.fromList vars args' = rights args - args'' = map g (zip args (annonVars (n + 1) (length args))) - args''' = map (VarExpr . stringToVar . (either id id)) args'' + args'' = zipWith (curry g) args (annonVars (n + 1) (length args)) + args''' = map (VarExpr . stringToVar . either id id) args'' in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args' where annonVars m n = take n $ map ((':':) . show) [m..] - f ((Left _), var) = Left var - f ((Right _), var) = Right var - g ((Left arg), _) = Left (':':arg) - g ((Right _), var) = Right var + f (Left _, var) = Left var + f (Right _, var) = Right var + g (Left arg, _) = Left (':':arg) + g (Right _, var) = Right var partialExpr :: Parser EgisonExpr -partialExpr = PartialExpr <$> read <$> index <*> (char '#' >> (try (parens expr) <|> expr)) +partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> (try (parens expr) <|> expr)) where index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit @@ -562,7 +563,7 @@ xs <- parens $ sepEndBy expr comma case xs of [x, y] -> return $ UserrefsExpr False x y - _ -> unexpected "number of arguments (expected 2)") + _ -> unexpected "number of arguments (expected 2)") <|> (do keywordUserrefsNew xs <- parens $ sepEndBy expr comma case xs of @@ -583,21 +584,19 @@ , [binary' "*" MultPat AssocRight, binary'' "/" DivPat AssocRight] , [binary' "+" PlusPat AssocRight] , [binary "<:>" "cons" AssocRight] - , [binary' "and" AndPat AssocLeft, binary' "or*" OrderedOrPat' AssocLeft, binary' "or" OrPat AssocLeft] + , [binary' "and" AndPat AssocLeft, binary' "or" OrPat AssocLeft] , [binary "<++>" "join" AssocRight] ] - unary op assoc = Prefix (try $ inSpaces (string op) >> (return $ \x -> NotPat x)) - binary op name assoc = Infix (try $ inSpaces (string op) >> (return $ \x y -> InductivePat name [x, y])) assoc - binary' op epr assoc = Infix (try $ inSpaces (string op) >> (return $ \x y -> epr [x, y])) assoc - binary'' op epr assoc = Infix (try $ inSpaces (string op) >> (return $ \x y -> epr x y)) assoc + unary op assoc = Prefix (try $ inSpaces (string op) >> return NotPat) + binary op name = Infix (try $ inSpaces (string op) >> return (\x y -> InductivePat name [x, y])) + binary' op epr = Infix (try $ inSpaces (string op) >> return (\x y -> epr [x, y])) + binary'' op epr = Infix (try $ inSpaces (string op) >> return epr) pattern' :: Parser EgisonPattern pattern' = wildCard <|> contPat <|> try indexedPat <|> patVar - <|> try dfsPat - <|> try bfsPat <|> try loopPat <|> try pApplyPat <|> try dApplyPat @@ -658,13 +657,7 @@ <|> (do s <- expr comma ep <- option WildCard pattern - return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep))) - -dfsPat :: Parser EgisonPattern -dfsPat = keywordDFS >> DFSPat' <$> parens pattern - -bfsPat :: Parser EgisonPattern -bfsPat = keywordBFS >> BFSPat <$> parens pattern + return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, IntegerExpr 1]))) ep))) -- Constants @@ -674,8 +667,8 @@ <|> try charExpr <|> try floatExpr <|> try integerExpr - <|> (keywordSomething *> pure SomethingExpr) - <|> (keywordUndefined *> pure UndefinedExpr) + <|> (keywordSomething $> SomethingExpr) + <|> (keywordUndefined $> UndefinedExpr) "constant" charExpr :: Parser EgisonExpr @@ -691,13 +684,11 @@ floatExpr = do (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i') <|> try ((,) 0 <$> floatLiteral' <* char 'i') - <|> try (flip (,) 0 <$> floatLiteral') + <|> try ((, 0) <$> floatLiteral') return $ FloatExpr x y integerExpr :: Parser EgisonExpr -integerExpr = do - n <- integerLiteral' - return $ IntegerExpr n +integerExpr = IntegerExpr <$> integerLiteral' integerLiteral' :: Parser Integer integerLiteral' = sign <*> positiveIntegerLiteral @@ -711,8 +702,8 @@ char '.' mStr <- many1 digit let m = read mStr - let l = m % (10 ^ (fromIntegral (length mStr))) - return (fromRational ((fromIntegral n) + l) :: Double) + let l = m % (10 ^ fromIntegral (length mStr)) + return (fromRational (fromIntegral n + l) :: Double) floatLiteral' :: Parser Double floatLiteral' = sign <*> positiveFloatLiteral @@ -770,11 +761,11 @@ , "withSymbols" , "loop" , "matchAll" + , "matchAllDFS" , "matchAllLambda" , "match" , "matchLambda" , "matcher" - , "matcherDFS" , "do" , "io" , "something" @@ -789,9 +780,7 @@ , "suprefs!" , "userRefs" , "userRefs!" - , "function" - , "dfs" - , "bfs"] + , "function"] reservedOperators :: [String] reservedOperators = @@ -804,6 +793,8 @@ , ")" , "->" , "`" + , "==" + , "=" -- , "'" -- , "~" -- , "!" @@ -817,7 +808,7 @@ reservedOp :: String -> Parser () reservedOp = P.reservedOp lexer -keywordDefine = reserved "define" +keywordDefine = reserved "def" keywordSet = reserved "set!" keywordTest = reserved "test" keywordLoadFile = reserved "loadFile" @@ -843,11 +834,11 @@ keywordLoop = reserved "loop" keywordCont = reserved "..." keywordMatchAll = reserved "matchAll" +keywordMatchAllDFS = reserved "matchAllDFS" keywordMatchAllLambda = reserved "matchAllLambda" keywordMatch = reserved "match" keywordMatchLambda = reserved "matchLambda" keywordMatcher = reserved "matcher" -keywordMatcherDFS = reserved "matcherDFS" keywordDo = reserved "do" keywordIo = reserved "io" keywordSomething = reserved "something" @@ -863,8 +854,6 @@ keywordUserrefs = reserved "userRefs" keywordUserrefsNew = reserved "userRefs!" keywordFunction = reserved "function" -keywordDFS = reserved "dfs" -keywordBFS = reserved "bfs" sign :: Num a => Parser (a -> a) sign = (char '-' >> return negate) @@ -897,7 +886,7 @@ return $ doParse' charLiteral $ "'" ++ x ++ "'" boolLiteral :: Parser Bool -boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False) +boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False) whiteSpace :: Parser () whiteSpace = P.whiteSpace lexer @@ -929,8 +918,8 @@ let (f, s) = splitLast idt '.' case s of [] -> return f - x:xs | isLower x -> return $ f ++ (map toLower $ intercalate "-" $ split (startsWithOneOf ['A'..'Z']) s) - | otherwise -> return $ f ++ [x] ++ (map toLower $ intercalate "-" $ split (startsWithOneOf ['A'..'Z']) xs) + x:xs | isLower x -> return $ f ++ map toLower (intercalate "-" $ split (startsWithOneOf ['A'..'Z']) s) + | otherwise -> return $ f ++ [x] ++ map toLower (intercalate "-" $ split (startsWithOneOf ['A'..'Z']) xs) where splitLast list elem = let (f, s) = span (/= elem) $ reverse list in (reverse s, reverse f) @@ -942,9 +931,7 @@ return $ Var (splitOn "." name) is) identVarWithoutIndex :: Parser Var -identVarWithoutIndex = do - x <- ident - return $ stringToVar x +identVarWithoutIndex = stringToVar <$> ident identVarWithIndices :: Parser VarWithIndices identVarWithIndices = P.lexeme lexer (do @@ -961,7 +948,7 @@ <|> try (char '_' >> return (Subscript ())) upperName :: Parser String -upperName = P.lexeme lexer $ upperName' +upperName = P.lexeme lexer upperName' upperName' :: Parser String upperName' = (:) <$> upper <*> option "" ident @@ -970,7 +957,7 @@ upper = satisfy isUpper lowerName :: Parser String -lowerName = P.lexeme lexer $ lowerName' +lowerName = P.lexeme lexer lowerName' lowerName' :: Parser String lowerName' = (:) <$> lower <*> option "" ident diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -1,4 +1,5 @@ -{-# Language FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {- | Module : Language.Egison.Primitives @@ -10,35 +11,35 @@ module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where -import Control.Arrow -import Control.Monad.Except -import Control.Monad.Trans.Maybe -import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) +import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) +import Control.Arrow +import Control.Monad.Except +import Control.Monad.Trans.Maybe -import Data.IORef -import Data.Ratio -import Data.Foldable (toList) -import Text.Regex.TDFA +import Data.Foldable (toList) +import Data.IORef +import Data.Ratio +import Text.Regex.TDFA -import System.IO -import System.Random -import System.Process +import System.IO +import System.Process +import System.Random -import qualified Data.Sequence as Sq -import qualified Data.Vector as V +import qualified Data.Sequence as Sq +import qualified Data.Vector as V -import Data.Char (ord, chr) -import qualified Data.Text as T -import Data.Text (Text) -import qualified Data.Text.IO as T +import Data.Char (chr, ord) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T {-- -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite --} -- for 'egison-sqlite' -import Language.Egison.Types -import Language.Egison.Parser -import Language.Egison.Core +import Language.Egison.Core +import Language.Egison.Parser +import Language.Egison.Types primitiveEnv :: IO Env primitiveEnv = do @@ -62,7 +63,7 @@ args' <- tupleToList args case args' of [] -> Value <$> f - _ -> throwError $ ArgumentsNumPrimitive 0 $ length args' + _ -> throwError $ ArgumentsNumPrimitive 0 $ length args' {-# INLINE oneArg #-} oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc @@ -85,12 +86,12 @@ twoArgs f args = do args' <- tupleToList args case args' of - [TensorData t1@(Tensor _ _ _), TensorData t2@(Tensor _ _ _)] -> Value <$> (tProduct f t1 t2 >>= fromTensor) + [TensorData t1@Tensor{}, TensorData t2@Tensor{}] -> Value <$> (tProduct f t1 t2 >>= fromTensor) [TensorData(Tensor ns ds js), val] -> do - ds' <- V.mapM (\d -> f d val) ds + ds' <- V.mapM (`f` val) ds Value <$> fromTensor (Tensor ns ds' js) [val, TensorData (Tensor ns ds js)] -> do - ds' <- V.mapM (\d -> f val d) ds + ds' <- V.mapM (f val) ds Value <$> fromTensor (Tensor ns ds' js) [val, val'] -> Value <$> f val val' _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' @@ -101,7 +102,7 @@ args' <- tupleToList args case args' of [val, val'] -> Value <$> f val val' - _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' + _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' {-# INLINE threeArgs' #-} threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc @@ -109,7 +110,7 @@ args' <- tupleToList args case args' of [val, val', val''] -> Value <$> f val val' val'' - _ -> throwError $ ArgumentsNumPrimitive 3 $ length args' + _ -> throwError $ ArgumentsNumPrimitive 3 $ length args' -- -- Constants @@ -342,7 +343,7 @@ toScalarData :: PrimitiveFunc toScalarData = oneArg toScalarData' where - toScalarData' val = (ScalarData . mathNormalize') <$> egisonToScalarData val + toScalarData' val = ScalarData . mathNormalize' <$> egisonToScalarData val -- -- Pred @@ -411,13 +412,13 @@ realPart = oneArg realPart' where realPart' (Float x y) = return $ Float x 0 - realPart' val = throwError $ TypeMismatch "float" (Value val) + realPart' val = throwError $ TypeMismatch "float" (Value val) imaginaryPart :: PrimitiveFunc imaginaryPart = oneArg imaginaryPart' where imaginaryPart' (Float _ y) = return $ Float y 0 - imaginaryPart' val = throwError $ TypeMismatch "float" (Value val) + imaginaryPart' val = throwError $ TypeMismatch "float" (Value val) -- -- Tensor @@ -553,7 +554,7 @@ ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []]))) (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []]))) - (ScalarData (Div (Plus [Term 1 [(Symbol _ _ _, 1)]]) (Plus [Term 1 []])), + (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])), _) -> throwError $ TypeMismatch "symbol or integer" (Value sub) _ -> throwError $ TypeMismatch "symbol or integer" (Value fn) @@ -563,16 +564,16 @@ ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []]))) (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []]))) - (ScalarData (Div (Plus [Term 1 [(Symbol _ _ _, 1)]]) (Plus [Term 1 []])), + (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])), _) -> throwError $ TypeMismatch "symbol" (Value sub) _ -> throwError $ TypeMismatch "symbol" (Value fn) readProcess' :: PrimitiveFunc readProcess' = threeArgs' $ \cmd args input -> case (cmd, args, input) of (String cmdStr, Collection argStrs, String inputStr) -> do - outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\arg -> case arg of - String argStr -> T.unpack argStr) - (toList argStrs)) (T.unpack inputStr) + outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\case + String argStr -> T.unpack argStr) + (toList argStrs)) (T.unpack inputStr) return (String (T.pack outputStr)) (_, _, _) -> throwError $ TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input])) @@ -583,7 +584,7 @@ readTSV= oneArg' $ \val -> do rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv) case rets of [ret] -> return ret - _ -> return (Tuple rets) + _ -> return (Tuple rets) show' :: PrimitiveFunc show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val @@ -662,7 +663,7 @@ ] makeIO :: EgisonM EgisonValue -> EgisonValue -makeIO m = IOFunc $ liftM (Value . Tuple . (World :) . (:[])) m +makeIO m = IOFunc $ fmap (Value . Tuple . (World :) . (:[])) m makeIO' :: EgisonM () -> EgisonValue makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []]) @@ -712,7 +713,7 @@ return $ makeIO' $ liftIO $ hFlush port readChar :: PrimitiveFunc -readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar +readChar = noArg $ return $ makeIO $ liftIO $ fmap Char getChar readCharFromPort :: PrimitiveFunc readCharFromPort = oneArg' $ \val -> do @@ -721,7 +722,7 @@ return $ makeIO $ return (Char c) readLine :: PrimitiveFunc -readLine = noArg $ return $ makeIO $ liftIO $ liftM toEgison T.getLine +readLine = noArg $ return $ makeIO $ liftIO $ fmap toEgison T.getLine readLineFromPort :: PrimitiveFunc readLineFromPort = oneArg' $ \val -> do @@ -736,7 +737,7 @@ return $ makeIO $ return $ toEgison s isEOFStdin :: PrimitiveFunc -isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF +isEOFStdin = noArg $ return $ makeIO $ liftIO $ fmap Bool isEOF isEOFPort :: PrimitiveFunc isEOFPort = oneArg' $ \val -> do 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 @@ -1,6 +1,14 @@ -{-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable, - TypeFamilies, TupleSections, DeriveGeneric, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {- | Module : Language.Egison.Types Copyright : Satoshi Egi @@ -96,19 +104,11 @@ -- * Pattern matching , Match , PMMode (..) - , pmMode , MatchingTree (..) , MatchingState (..) - , MatchingStates (..) , PatternBinding (..) , LoopPatContext (..) - , topDFS - , containBFS - -- * makeLenses - , normalTree - , orderedOrTrees - , ids - , bool + , SeqPatContext (..) -- * Errors , EgisonError (..) , liftError @@ -160,47 +160,50 @@ , varToVarWithIndices ) where -import Prelude hiding (foldr, mappend, mconcat) +import Prelude hiding (foldr, mappend, mconcat) -import Control.Exception -import Control.Parallel -import Control.Lens (makeLenses) -import Data.Typeable +import Control.Exception +import Control.Lens (makeLenses) +import Control.Parallel +import Data.Typeable -import Control.Applicative -import Control.Monad.Except -import Control.Monad.State -import Control.Monad.Fail -import Control.Monad.Reader (ReaderT) -import Control.Monad.Writer (WriterT) -import Control.Monad.Identity -import Control.Monad.Trans.Maybe +import Control.Applicative +import Control.Monad.Except +import Control.Monad.Fail +import Control.Monad.Identity +import Control.Monad.Reader (ReaderT) +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Control.Monad.Writer (WriterT) -import Data.Monoid (Monoid) -import qualified Data.HashMap.Lazy as HL -import qualified Data.Array as Array -import qualified Data.Vector as V -import qualified Data.Sequence as Sq -import Data.Sequence (Seq) -import Data.Foldable (foldr, toList) -import Data.IORef -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Map (Map) +import qualified Data.Array as Array +import Data.Foldable (foldr, toList) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Lazy as HL +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.IORef +import Data.Map (Map) +import Data.Monoid (Monoid) +import Data.Sequence (Seq) +import qualified Data.Sequence as Sq +import qualified Data.Vector as V -import Data.List (intercalate, sort, sortBy, find, findIndex, splitAt, (\\), elem, delete, deleteBy, any, partition, intercalate, elemIndex) -import Data.List.Split (splitOn) -import Data.Text (Text, pack) -import qualified Data.Text as T +import Data.List (any, delete, deleteBy, elem, + elemIndex, find, findIndex, + intercalate, partition, sort, + sortBy, splitAt, (\\)) +import Data.List.Split (splitOn) +import Data.Text (Text, pack) +import qualified Data.Text as T -import System.IO -import Data.Ratio -import Numeric +import Data.Ratio +import Numeric +import System.IO -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) -import GHC.Generics (Generic) +import GHC.Generics (Generic) -- -- Expressions @@ -253,11 +256,11 @@ | MatchExpr EgisonExpr EgisonExpr [MatchClause] | MatchAllExpr EgisonExpr EgisonExpr [MatchClause] + | MatchAllDFSExpr EgisonExpr EgisonExpr [MatchClause] | MatchLambdaExpr EgisonExpr [MatchClause] | MatchAllLambdaExpr EgisonExpr [MatchClause] | MatcherExpr MatcherInfo - | MatcherDFSExpr MatcherInfo | AlgebraicDataMatcherExpr [(String, [EgisonExpr])] | QuoteExpr EgisonExpr @@ -337,23 +340,21 @@ | NotPat EgisonPattern | AndPat [EgisonPattern] | OrPat [EgisonPattern] - | OrderedOrPat' [EgisonPattern] - | OrderedOrPat Id EgisonPattern EgisonPattern | TuplePat [EgisonPattern] | InductivePat String [EgisonPattern] | LoopPat Var LoopRange EgisonPattern EgisonPattern | ContPat | PApplyPat EgisonExpr [EgisonPattern] | VarPat String + | SeqNilPat + | SeqConsPat EgisonPattern EgisonPattern + | LaterPatVar -- For symbolic computing | DApplyPat EgisonPattern [EgisonPattern] | DivPat EgisonPattern EgisonPattern | PlusPat [EgisonPattern] | MultPat [EgisonPattern] | PowerPat EgisonPattern EgisonPattern - | DFSPat' EgisonPattern - | DFSPat Id EgisonPattern - | BFSPat EgisonPattern deriving (Show, Eq) data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern @@ -396,7 +397,7 @@ | IntHash (HashMap Integer EgisonValue) | CharHash (HashMap Char EgisonValue) | StrHash (HashMap Text EgisonValue) - | UserMatcher Env MatcherInfo PMMode + | UserMatcher Env MatcherInfo | Func (Maybe Var) Env [String] EgisonExpr | PartialFunc Env Integer EgisonExpr | CFunc (Maybe Var) Env String EgisonExpr @@ -486,7 +487,7 @@ fromTensor t@Tensor{} = return $ TensorData t fromTensor (Scalar x) = return x toTensor (TensorData t) = return t - toTensor x = return $ Scalar x + toTensor x = return $ Scalar x undef = Undefined instance HasTensor WHNFData where @@ -496,7 +497,7 @@ fromTensor t@Tensor{} = return $ Intermediate $ ITensor t fromTensor (Scalar x) = return x toTensor (Intermediate (ITensor t)) = return t - toTensor x = return $ Scalar x + toTensor x = return $ Scalar x undef = Value Undefined -- @@ -524,10 +525,10 @@ symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue symbolExprToEgison (Symbol id x js, n) = Tuple [InductiveData "Symbol" [symbolScalarData id x, f js], toEgison n] where - f js = Collection (Sq.fromList (map (\j -> case j of - Superscript k -> InductiveData "Sup" [ScalarData k] - Subscript k -> InductiveData "Sub" [ScalarData k] - Userscript k -> InductiveData "User" [ScalarData k] + f js = Collection (Sq.fromList (map (\case + Superscript k -> InductiveData "Sup" [ScalarData k] + Subscript k -> InductiveData "Sub" [ScalarData k] + Userscript k -> InductiveData "User" [ScalarData k] ) js)) symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n] symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n] @@ -535,10 +536,10 @@ Nothing -> Tuple [InductiveData "Function" [symbolScalarData "" "", Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n] Just name' -> Tuple [InductiveData "Function" [name', Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n] where - f js = Collection (Sq.fromList (map (\j -> case j of - Superscript k -> InductiveData "Sup" [ScalarData k] - Subscript k -> InductiveData "Sub" [ScalarData k] - Userscript k -> InductiveData "User" [ScalarData k] + f js = Collection (Sq.fromList (map (\case + Superscript k -> InductiveData "Sup" [ScalarData k] + Subscript k -> InductiveData "Sub" [ScalarData k] + Userscript k -> InductiveData "User" [ScalarData k] ) js)) egisonToScalarData :: EgisonValue -> EgisonM ScalarData @@ -573,10 +574,10 @@ egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do let js = toList seq js' <- mapM (\j -> case j of - InductiveData "Sup" [ScalarData k] -> return (Superscript k) - InductiveData "Sub" [ScalarData k] -> return (Subscript k) - InductiveData "User" [ScalarData k] -> return (Userscript k) - _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j) + InductiveData "Sup" [ScalarData k] -> return (Superscript k) + InductiveData "Sub" [ScalarData k] -> return (Subscript k) + InductiveData "User" [ScalarData k] -> return (Userscript k) + _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j) ) js n' <- fromEgison n case x of @@ -590,7 +591,7 @@ mExpr' <- egisonToScalarData mExpr n' <- fromEgison n return (Quote mExpr', n') -egisonToSymbolExpr (Tuple [InductiveData "Function" [name, (Collection argnames), (Collection args), Collection seq], n]) = do +egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args, Collection seq], n]) = do let js = toList seq js' <- mapM (\j -> case j of InductiveData "Sup" [ScalarData k] -> return (Superscript k) @@ -601,7 +602,7 @@ n' <- fromEgison n let name' = case getSymName name of "" -> Nothing - s -> Just $ name + s -> Just name return (FunctionData name' (toList argnames) (toList args) js', n') egisonToSymbolExpr val = liftError $ throwError $ TypeMismatch "math symbol expression" (Value val) @@ -637,9 +638,9 @@ case z of (Term c zs) -> case ts2 of [Term a _] -> if a < 0 - then (Div (Plus (map (\t -> mathDivideTerm t (Term (-1 * c) zs)) ts1)) (Plus (map (\t -> mathDivideTerm t (Term (-1 * c) zs)) ts2))) - else (Div (Plus (map (\t -> mathDivideTerm t z) ts1)) (Plus (map (\t -> mathDivideTerm t z) ts2))) - _ -> (Div (Plus (map (\t -> mathDivideTerm t z) ts1)) (Plus (map (\t -> mathDivideTerm t z) ts2))) + then Div (Plus (map (`mathDivideTerm` Term (-1 * c) zs) ts1)) (Plus (map (`mathDivideTerm` Term (-1 * c) zs) ts2)) + else Div (Plus (map (`mathDivideTerm` z) ts1)) (Plus (map (`mathDivideTerm` z) ts2)) + _ -> Div (Plus (map (`mathDivideTerm` z) ts1)) (Plus (map (`mathDivideTerm` z) ts2)) mathDivideTerm :: TermExpr -> TermExpr -> TermExpr mathDivideTerm (Term a xs) (Term b ys) = @@ -665,7 +666,7 @@ mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) = let p x = case x of (_, 0) -> False - _ -> True in + _ -> True in let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1 in let ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2 in Div (Plus ts1') (Plus ts2') @@ -676,7 +677,7 @@ let ts2' = filter (\(Term a _) -> a /= 0) ts2 in case ts1' of [] -> Div (Plus []) (Plus [Term 1 []]) - _ -> Div (Plus ts1') (Plus ts2') + _ -> Div (Plus ts1') (Plus ts2') mathFold :: ScalarData -> ScalarData mathFold mExpr = mathTermFold (mathSymbolFold (mathTermFold mExpr)) @@ -695,7 +696,7 @@ else g (ret ++ [((x, n), 1)]) xs p :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> Bool p (Quote x, _) ((Quote y, _),_) = (x == y) || (mathNegate x == y) - p (x, _) ((y, _),_) = x == y + p (x, _) ((y, _),_) = x == y h :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> ((SymbolExpr, Integer), Integer) h (Quote x, n) ((Quote y, m), sgn) | x == y = ((Quote y, m + n), sgn) @@ -794,26 +795,29 @@ tSize :: Tensor a -> [Integer] tSize (Tensor ns _ _) = ns -tSize (Scalar _) = [] +tSize (Scalar _) = [] tToList :: Tensor a -> [a] tToList (Tensor _ xs _) = V.toList xs -tToList (Scalar x) = [x] +tToList (Scalar x) = [x] tToVector :: Tensor a -> V.Vector a tToVector (Tensor _ xs _) = xs -tToVector (Scalar x) = V.fromList [x] +tToVector (Scalar x) = V.fromList [x] tIndex :: Tensor a -> [Index EgisonValue] tIndex (Tensor _ _ js) = js -tIndex (Scalar _) = [] +tIndex (Scalar _) = [] tIntRef' :: HasTensor a => Integer -> Tensor a -> EgisonM a -tIntRef' i (Tensor [_] xs _) = fromTensor $ Scalar $ xs V.! (fromIntegral (i - 1)) +tIntRef' i (Tensor [n] xs _) = + if (0 < i) && (i <= n) + then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1) + else throwError $ TensorIndexOutOfBounds i n tIntRef' i (Tensor (n:ns) xs js) = if (0 < i) && (i <= n) then let w = fromIntegral (product ns) in - let ys = V.take w (V.drop (w * (fromIntegral (i - 1))) xs) in + let ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs) in fromTensor $ Tensor ns ys (cdr js) else throwError $ TensorIndexOutOfBounds i n tIntRef' i _ = throwError $ Default "More indices than the order of the tensor" @@ -885,7 +889,7 @@ transIndex [] [] is = return is transIndex (j1:js1) js2 is = do let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2 - if tjs2 == [] + if null tjs2 then throwError InconsistentTensorIndex else do let n = length hjs2 + 1 rs <- transIndex js1 (hjs2 ++ tail tjs2) (take (n - 1) is ++ drop n is) @@ -895,7 +899,7 @@ tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a) tTranspose is t@(Tensor ns xs js) = do ns' <- transIndex js is ns - xs' <- mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor >>= return . V.fromList + xs' <- V.fromList <$> mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor return $ Tensor ns' xs' is tTranspose' :: HasTensor a => [EgisonValue] -> Tensor a -> EgisonM (Tensor a) @@ -904,8 +908,8 @@ tTranspose is' t where f :: Index EgisonValue -> EgisonValue - f (Subscript i) = i - f (Superscript i) = i + f (Subscript i) = i + f (Superscript i) = i f (SupSubscript i) = i g :: [EgisonValue] -> [Index EgisonValue] -> EgisonM [Index EgisonValue] g [] js = return [] @@ -917,9 +921,9 @@ tFlipIndices :: HasTensor a => Tensor a -> EgisonM (Tensor a) tFlipIndices (Tensor ns xs js) = return $ Tensor ns xs (map flipIndex js) where - flipIndex (Subscript i) = Superscript i + flipIndex (Subscript i) = Superscript i flipIndex (Superscript i) = Subscript i - flipIndex x = x + flipIndex x = x appendDFscripts :: Integer -> WHNFData -> EgisonM WHNFData appendDFscripts id (Intermediate (ITensor (Tensor s xs is))) = do @@ -937,21 +941,21 @@ return (Intermediate (ITensor (Tensor s ys js))) where isDF (DFscript _ _) = True - isDF _ = False + isDF _ = False removeDFscripts (Value (TensorData (Tensor s xs is))) = do let (ds, js) = partition isDF is (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is) return (Value (TensorData (Tensor s ys js))) where isDF (DFscript _ _) = True - isDF _ = False + isDF _ = False removeDFscripts whnf = return whnf tMap :: HasTensor a => (a -> EgisonM a) -> Tensor a -> EgisonM (Tensor a) tMap f (Tensor ns xs js') = do let k = fromIntegral $ length ns - length js' let js = js' ++ map (DFscript 0) [1..k] - xs' <- mapM f (V.toList xs) >>= return . V.fromList + xs' <- V.fromList <$> mapM f (V.toList xs) t <- toTensor (V.head xs') case t of (Tensor ns1 _ js1') -> do @@ -979,7 +983,7 @@ let cns = take (length cjs) (tSize t1') rts1 <- mapM (`tIntRef` t1') (enumTensorIndices cns) rts2 <- mapM (`tIntRef` t2') (enumTensorIndices cns) - rts' <- mapM (\(t1, t2) -> tProduct f t1 t2) (zip rts1 rts2) + rts' <- zipWithM (tProduct f) rts1 rts2 let ret = Tensor (cns ++ tSize (head rts')) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts')) tTranspose (uniq (tDiagIndex (js1 ++ js2))) ret where @@ -987,14 +991,14 @@ h js1 js2 = let cjs = filter (`elem` js2) js1 in (cjs, js1 \\ cjs, js2 \\ cjs) uniq :: [Index EgisonValue] -> [Index EgisonValue] - uniq [] = [] + uniq [] = [] uniq (x:xs) = x:uniq (delete x xs) -tMap2 f t@(Tensor _ _ _) (Scalar x) = tMap (`f` x) t -tMap2 f (Scalar x) t@(Tensor _ _ _) = tMap (f x) t +tMap2 f t@Tensor{} (Scalar x) = tMap (`f` x) t +tMap2 f (Scalar x) t@Tensor{} = tMap (f x) t tMap2 f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2 tDiag :: HasTensor a => Tensor a -> EgisonM (Tensor a) -tDiag t@(Tensor _ _ js) = do +tDiag t@(Tensor _ _ js) = case filter (\j -> any (p j) js) js of [] -> return t xs -> do @@ -1007,14 +1011,14 @@ where p :: Index EgisonValue -> Index EgisonValue -> Bool p (Superscript i) (Subscript j) = i == j - p (Subscript i) _ = False - p _ _ = False + p (Subscript i) _ = False + p _ _ = False rev :: Index EgisonValue -> Index EgisonValue rev (Superscript i) = Subscript i - rev (Subscript i) = Superscript i + rev (Subscript i) = Superscript i g :: Index EgisonValue -> Index EgisonValue g (Superscript i) = SupSubscript i - g (Subscript i) = SupSubscript i + g (Subscript i) = SupSubscript i tDiag t = return t tDiagIndex :: [Index EgisonValue] -> [Index EgisonValue] @@ -1025,21 +1029,21 @@ where p :: Index EgisonValue -> Index EgisonValue -> Bool p (Superscript i) (Subscript j) = i == j - p (Subscript _) _ = False - p _ _ = False + p (Subscript _) _ = False + p _ _ = False rev :: Index EgisonValue -> Index EgisonValue rev (Superscript i) = Subscript i - rev (Subscript i) = Superscript i + rev (Subscript i) = Superscript i g :: Index EgisonValue -> Index EgisonValue g (Superscript i) = SupSubscript i - g (Subscript i) = SupSubscript i + g (Subscript i) = SupSubscript i tSum :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a) -tSum f t1@(Tensor ns1 xs1 js1) t2@(Tensor _ _ _) = do +tSum f t1@(Tensor ns1 xs1 js1) t2@Tensor{} = do t2' <- tTranspose js1 t2 case t2' of (Tensor ns2 xs2 _) - | ns2 == ns1 -> do ys <- V.mapM (\(x1,x2) -> f x1 x2) (V.zip xs1 xs2) + | ns2 == ns1 -> do ys <- V.mapM (uncurry f) (V.zip xs1 xs2) return (Tensor ns1 ys js1) | otherwise -> throwError InconsistentTensorSize @@ -1050,15 +1054,16 @@ let k2 = fromIntegral $ length ns2 - length js2' let js2 = js2' ++ map (DFscript 0) [1..k2] let (cjs1, cjs2, tjs1, tjs2) = h js1 js2 - let t1 = (Tensor ns1 xs1 js1) - let t2 = (Tensor ns2 xs2 js2) + let t1 = Tensor ns1 xs1 js1 + let t2 = Tensor ns2 xs2 js2 case cjs1 of [] -> do - xs' <- mapM (\is -> do let is1 = take (length ns1) is - let is2 = take (length ns2) (drop (length ns1) is) - x1 <- tIntRef is1 t1 >>= fromTensor - x2 <- tIntRef is2 t2 >>= fromTensor - f x1 x2) (enumTensorIndices (ns1 ++ ns2)) >>= return . V.fromList + xs' <- V.fromList <$> mapM (\is -> do + let is1 = take (length ns1) is + let is2 = take (length ns2) (drop (length ns1) is) + x1 <- tIntRef is1 t1 >>= fromTensor + x2 <- tIntRef is2 t2 >>= fromTensor + f x1 x2) (enumTensorIndices (ns1 ++ ns2)) tContract' (Tensor (ns1 ++ ns2) xs' (js1 ++ js2)) _ -> do t1' <- tTranspose (cjs1 ++ tjs1) t1 @@ -1069,8 +1074,7 @@ rt2 <- tIntRef is t2' tProduct f rt1 rt2) (enumTensorIndices cns1) let ret = Tensor (cns1 ++ tSize (head rts')) (V.concat (map tToVector rts')) (map g cjs1 ++ tIndex (head rts')) - ret2 <- tTranspose (uniq (map g cjs1 ++ tjs1 ++ tjs2)) ret - return ret2 + tTranspose (uniq (map g cjs1 ++ tjs1 ++ tjs2)) ret where h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue], [Index EgisonValue]) h js1 js2 = let cjs = filter (\j -> any (p j) js2) js1 in @@ -1078,15 +1082,15 @@ p :: Index EgisonValue -> Index EgisonValue -> Bool p (Superscript i) (Subscript j) = i == j p (Subscript i) (Superscript j) = i == j - p _ _ = False + p _ _ = False rev :: Index EgisonValue -> Index EgisonValue rev (Superscript i) = Subscript i - rev (Subscript i) = Superscript i + rev (Subscript i) = Superscript i g :: Index EgisonValue -> Index EgisonValue g (Superscript i) = SupSubscript i - g (Subscript i) = SupSubscript i + g (Subscript i) = SupSubscript i uniq :: [Index EgisonValue] -> [Index EgisonValue] - uniq [] = [] + uniq [] = [] uniq (x:xs) = x:uniq (delete x xs) tProduct f (Scalar x) (Tensor ns xs js) = do xs' <- V.mapM (f x) xs @@ -1107,23 +1111,23 @@ _ -> return [t'] tContract' :: HasTensor a => Tensor a -> EgisonM (Tensor a) -tContract' t@(Tensor ns xs js) = do +tContract' t@(Tensor ns xs js) = case findPairs p js of [] -> return t ((m,n):_) -> do let ns' = (ns !! m):removePairs (m,n) ns let js' = (js !! m):removePairs (m,n) js let (hjs, mjs, tjs) = removePairs' (m,n) js - xs' <- mapM (\i -> (tref (hjs ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ mjs - ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ tjs) t)) + xs' <- mapM (\i -> tref (hjs ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ mjs + ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ tjs) t) [1..(ns !! m)] mapM toTensor xs' >>= tConcat (js !! m) >>= tTranspose (hjs ++ [js !! m] ++ mjs ++ tjs) >>= tContract' where p :: Index EgisonValue -> Index EgisonValue -> Bool - p (Superscript i) (Superscript j) = i == j - p (Subscript i) (Subscript j) = i == j + p (Superscript i) (Superscript j) = i == j + p (Subscript i) (Subscript j) = i == j p (DFscript i1 j1) (DFscript i2 j2) = (i1 == i2) && (j1 == j2) - p _ _ = False + p _ _ = False tContract' val = return val -- utility functions for tensors @@ -1132,7 +1136,7 @@ nth i xs = xs !! fromIntegral (i - 1) cdr :: [a] -> [a] -cdr [] = [] +cdr [] = [] cdr (_:ts) = ts split :: Integer -> V.Vector a -> [V.Vector a] @@ -1157,7 +1161,7 @@ getScalar :: Tensor a -> EgisonM a getScalar (Scalar x) = return x -getScalar _ = throwError $ Default "Inconsitent Tensor order" +getScalar _ = throwError $ Default "Inconsitent Tensor order" findPairs :: (a -> a -> Bool) -> [a] -> [(Int, Int)] findPairs p xs = reverse $ findPairs' 0 p xs @@ -1165,7 +1169,7 @@ findPairs' :: Int -> (a -> a -> Bool) -> [a] -> [(Int, Int)] findPairs' _ _ [] = [] findPairs' m p (x:xs) = case findIndex (p x) xs of - Just i -> (m, m + i + 1):findPairs' (m + 1) p xs + Just i -> (m, m + i + 1):findPairs' (m + 1) p xs Nothing -> findPairs' (m + 1) p xs removePairs :: (Int, Int) -> [a] -> [a] @@ -1235,7 +1239,7 @@ show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (CharHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ T.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" - show (UserMatcher _ _ _) = "#" + show UserMatcher{} = "#" show (Func Nothing _ args _) = "(lambda [" ++ unwords (map show args) ++ "] ...)" show (Func (Just name) _ _ _) = show name show (PartialFunc _ n expr) = show n ++ "#" ++ show expr @@ -1246,7 +1250,7 @@ show (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)" show (Proc (Just name) _ _ _) = name show (Macro names _) = "(macro [" ++ unwords names ++ "] ...)" - show (PatternFunc _ _ _) = "#" + show PatternFunc{} = "#" show (PrimitiveFunc name _) = "#" show (IOFunc _) = "#" show (QuotedFunc _) = "#" @@ -1257,18 +1261,18 @@ show EOF = "#" instance Show Arg where - show (ScalarArg name) = "$" ++ name + show (ScalarArg name) = "$" ++ name show (InvertedScalarArg name) = "*$" ++ name - show (TensorArg name) = "%" ++ name + show (TensorArg name) = "%" ++ name instance Show ScalarData where show (Div p1 (Plus [Term 1 []])) = show p1 - show (Div p1 p2) = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")" + show (Div p1 p2) = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")" instance Show PolyExpr where - show (Plus []) = "0" + show (Plus []) = "0" show (Plus [t]) = show t - show (Plus ts) = "(+ " ++ unwords (map show ts) ++ ")" + show (Plus ts) = "(+ " ++ unwords (map show ts) ++ ")" instance Show TermExpr where show (Term a []) = show a @@ -1286,7 +1290,7 @@ show (Symbol _ s js) = s ++ concatMap show js show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")" show (Quote mExprs) = "'" ++ show mExprs - show (FunctionData Nothing argnames args js) = "(function [" ++ unwords (map show argnames) ++ "])" ++ concatMap show js + show (FunctionData Nothing argnames args js) = "(functionData [" ++ unwords (map show argnames) ++ "])" ++ concatMap show js show (FunctionData (Just name) argnames args js) = show name ++ concatMap show js showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String @@ -1401,15 +1405,15 @@ fromCharValue :: EgisonValue -> Either EgisonError Char fromCharValue (Char c) = return c -fromCharValue val = throwError $ TypeMismatch "char" (Value val) +fromCharValue val = throwError $ TypeMismatch "char" (Value val) fromStringValue :: EgisonValue -> Either EgisonError Text fromStringValue (String str) = return str -fromStringValue val = throwError $ TypeMismatch "string" (Value val) +fromStringValue val = throwError $ TypeMismatch "string" (Value val) fromBoolValue :: EgisonValue -> Either EgisonError Bool fromBoolValue (Bool b) = return b -fromBoolValue val = throwError $ TypeMismatch "bool" (Value val) +fromBoolValue val = throwError $ TypeMismatch "bool" (Value val) fromIntegerValue :: EgisonValue -> Either EgisonError Integer fromIntegerValue (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0 @@ -1423,11 +1427,11 @@ fromFloatValue :: EgisonValue -> Either EgisonError Double fromFloatValue (Float f 0) = return f -fromFloatValue val = throwError $ TypeMismatch "float" (Value val) +fromFloatValue val = throwError $ TypeMismatch "float" (Value val) fromPortValue :: EgisonValue -> Either EgisonError Handle fromPortValue (Port h) = return h -fromPortValue val = throwError $ TypeMismatch "port" (Value val) +fromPortValue val = throwError $ TypeMismatch "port" (Value val) -- -- Internal Data @@ -1471,7 +1475,7 @@ show (Intermediate (ITensor (Tensor ns xs _))) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]" instance Show Object where - show (Thunk _) = "#" + show (Thunk _) = "#" show (WHNF whnf) = show whnf instance Show ObjectRef where @@ -1505,15 +1509,15 @@ fromCharWHNF :: WHNFData -> Either EgisonError Char fromCharWHNF (Value (Char c)) = return c -fromCharWHNF whnf = throwError $ TypeMismatch "char" whnf +fromCharWHNF whnf = throwError $ TypeMismatch "char" whnf fromStringWHNF :: WHNFData -> Either EgisonError Text fromStringWHNF (Value (String str)) = return str -fromStringWHNF whnf = throwError $ TypeMismatch "string" whnf +fromStringWHNF whnf = throwError $ TypeMismatch "string" whnf fromBoolWHNF :: WHNFData -> Either EgisonError Bool fromBoolWHNF (Value (Bool b)) = return b -fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf +fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf fromIntegerWHNF :: WHNFData -> Either EgisonError Integer fromIntegerWHNF (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return 0 @@ -1522,11 +1526,11 @@ fromFloatWHNF :: WHNFData -> Either EgisonError Double fromFloatWHNF (Value (Float f 0)) = return f -fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf +fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf fromPortWHNF :: WHNFData -> Either EgisonError Handle fromPortWHNF (Value (Port h)) = return h -fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf +fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf class (EgisonWHNF a) => EgisonObject a where toObject :: a -> Object @@ -1559,32 +1563,32 @@ show (VarWithIndices xs is) = intercalate "." xs ++ concatMap show is instance Show (Index ()) where - show (Superscript ()) = "~" - show (Subscript ()) = "_" + show (Superscript ()) = "~" + show (Subscript ()) = "_" show (SupSubscript ()) = "~_" - show (DFscript _ _) = "" - show (Userscript _) = "|" + show (DFscript _ _) = "" + show (Userscript _) = "|" instance Show (Index String) where - show (Superscript s) = "~" ++ s - show (Subscript s) = "_" ++ s + show (Superscript s) = "~" ++ s + show (Subscript s) = "_" ++ s show (SupSubscript s) = "~_" ++ s - show (DFscript _ _) = "" - show (Userscript i) = "|" ++ show i + show (DFscript _ _) = "" + show (Userscript i) = "|" ++ show i instance Show (Index EgisonExpr) where - show (Superscript i) = "~" ++ show i - show (Subscript i) = "_" ++ show i + show (Superscript i) = "~" ++ show i + show (Subscript i) = "_" ++ show i show (SupSubscript i) = "~_" ++ show i - show (DFscript _ _) = "" - show (Userscript i) = "|" ++ show i + show (DFscript _ _) = "" + show (Userscript i) = "|" ++ show i instance Show (Index ScalarData) where - show (Superscript i) = "~" ++ show i - show (Subscript i) = "_" ++ show i + show (Superscript i) = "~" ++ show i + show (Subscript i) = "_" ++ show i show (SupSubscript i) = "~_" ++ show i - show (DFscript _ _) = "" - show (Userscript i) = "|" ++ show i + show (DFscript _ _) = "" + show (Userscript i) = "|" ++ show i instance Show (Index EgisonValue) where show (Superscript i) = case i of @@ -1614,58 +1618,26 @@ type Match = [Binding] -data PMMode = BFSMode | DFSMode Id +data PMMode = BFSMode | DFSMode deriving (Show) -data MatchingState = MState PMMode Env [LoopPatContext] [Binding] [MatchingTree] +data MatchingState = MState Env [LoopPatContext] [SeqPatContext] [Binding] [MatchingTree] instance Show MatchingState where - show (MState mode _ _ bindings mtrees) = "(MState " ++ intercalate " " [show mode, "_", "_", show bindings, show mtrees] ++ ")" - -pmMode :: MatchingState -> PMMode -pmMode (MState mode _ _ _ _) = mode + show (MState _ _ _ bindings mtrees) = "(MState " ++ unwords ["_", "_", "_", show bindings, show mtrees] ++ ")" data MatchingTree = MAtom EgisonPattern WHNFData Matcher | MNode [PatternBinding] MatchingState deriving (Show) -data MatchingStates = MatchingStates { _normalTree :: [[MList EgisonM MatchingState]], - _orderedOrTrees :: Map Id (Map Int [MList EgisonM MatchingState]), - _ids :: [Id], - _bool :: Bool - } deriving (Show) - type PatternBinding = (String, EgisonPattern) data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern deriving (Show) -topDFS :: EgisonPattern -> Bool -topDFS (DFSPat _ _) = True -topDFS (InductivePat _ (pattern:_)) = topDFS pattern -topDFS (LetPat _ pattern) = topDFS pattern -topDFS _ = False - -containBFS :: EgisonPattern -> Bool -containBFS (BFSPat _) = True -containBFS (IndexedPat pattern _) = containBFS pattern -containBFS (NotPat pattern) = containBFS pattern -containBFS (AndPat patterns) = any containBFS patterns -containBFS (OrPat patterns) = any containBFS patterns -containBFS (OrderedOrPat _ pat1 pat2) = containBFS pat1 || containBFS pat2 -containBFS (TuplePat patterns) = any containBFS patterns -containBFS (InductivePat _ patterns) = any containBFS patterns -containBFS (LoopPat _ _ pat1 pat2) = containBFS pat1 || containBFS pat2 -containBFS (PApplyPat _ patterns) = any containBFS patterns -containBFS (DApplyPat pat patterns) = any containBFS (pat:patterns) -containBFS (DivPat pat1 pat2) = containBFS pat1 || containBFS pat2 -containBFS (PlusPat patterns) = any containBFS patterns -containBFS (MultPat patterns) = any containBFS patterns -containBFS (PowerPat pat1 pat2) = containBFS pat1 || containBFS pat2 -containBFS (DFSPat _ pattern) = containBFS pattern -containBFS (LetPat _ pattern) = containBFS pattern -containBFS _ = False +data SeqPatContext = SeqPatContext [MatchingTree] EgisonPattern [Matcher] [WHNFData] + deriving (Show) -- -- Errors @@ -1754,6 +1726,7 @@ fromEgisonM :: EgisonM a -> IO (Either EgisonError a) fromEgisonM = modifyCounter . runEgisonM +{-# NOINLINE counter #-} counter :: IORef (Int, Int) counter = unsafePerformIO (newIORef (0, 0)) @@ -1789,24 +1762,24 @@ catchError m h = FreshT $ catchError (unFreshT m) (unFreshT . h) instance (MonadState s m) => MonadState s (FreshT m) where - get = lift $ get + get = lift get put s = lift $ put s instance (MonadFresh m) => MonadFresh (StateT s m) where - fresh = lift $ fresh - freshV = lift $ freshV + fresh = lift fresh + freshV = lift freshV instance (MonadFresh m) => MonadFresh (ExceptT e m) where - fresh = lift $ fresh - freshV = lift $ freshV + fresh = lift fresh + freshV = lift freshV instance (MonadFresh m, Monoid e) => MonadFresh (ReaderT e m) where - fresh = lift $ fresh - freshV = lift $ freshV + fresh = lift fresh + freshV = lift freshV instance (MonadFresh m, Monoid e) => MonadFresh (WriterT e m) where - fresh = lift $ fresh - freshV = lift $ freshV + fresh = lift fresh + freshV = lift freshV instance MonadIO (FreshT IO) where liftIO = lift @@ -1826,7 +1799,7 @@ data MList m a = MNil | MCons a (m (MList m a)) instance Show a => Show (MList m a) where - show MNil = "MNil" + show MNil = "MNil" show (MCons x _) = "(MCons " ++ show x ++ " ...)" fromList :: Monad m => [a] -> MList m a @@ -1845,7 +1818,7 @@ msingleton = flip MCons $ return MNil mfoldr :: Monad m => (a -> m b -> m b) -> m b -> MList m a -> m b -mfoldr f init MNil = init +mfoldr f init MNil = init mfoldr f init (MCons x xs) = f x (xs >>= mfoldr f init) mappend :: Monad m => MList m a -> m (MList m a) -> m (MList m a) @@ -1856,7 +1829,7 @@ mmap :: Monad m => (a -> m b) -> MList m a -> m (MList m b) mmap f = mfoldr g $ return MNil - where g x xs = f x >>= return . flip MCons xs + where g x xs = flip MCons xs <$> f x mfor :: Monad m => MList m a -> (a -> m b) -> m (MList m b) mfor = flip mmap @@ -1865,87 +1838,87 @@ isBool :: EgisonValue -> Bool isBool (Bool _) = True -isBool _ = False +isBool _ = False isBool' :: PrimitiveFunc isBool' (Value val) = return $ Value $ Bool $ isBool val isInteger :: EgisonValue -> Bool -isInteger (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = True +isInteger (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = True isInteger (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = True -isInteger _ = False +isInteger _ = False isInteger' :: PrimitiveFunc isInteger' (Value val) = return $ Value $ Bool $ isInteger val isRational :: EgisonValue -> Bool -isRational (ScalarData (Div (Plus []) (Plus [Term _ []]))) = True +isRational (ScalarData (Div (Plus []) (Plus [Term _ []]))) = True isRational (ScalarData (Div (Plus [Term _ []]) (Plus [Term _ []]))) = True -isRational _ = False +isRational _ = False isRational' :: PrimitiveFunc isRational' (Value val) = return $ Value $ Bool $ isRational val isSymbol :: EgisonValue -> Bool -isSymbol (ScalarData (Div (Plus [Term 1 [(Symbol _ _ _, 1)]]) (Plus [Term 1 []]))) = True +isSymbol (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []]))) = True isSymbol _ = False isScalar :: EgisonValue -> Bool isScalar (ScalarData _) = True -isScalar _ = False +isScalar _ = False isScalar' :: PrimitiveFunc isScalar' (Value val) = return $ Value $ Bool $ isScalar val -isScalar' _ = return $ Value $ Bool False +isScalar' _ = return $ Value $ Bool False isTensor :: EgisonValue -> Bool isTensor (TensorData _) = True -isTensor _ = False +isTensor _ = False isTensor' :: PrimitiveFunc isTensor' (Value val) = return $ Value $ Bool $ isTensor val -isTensor' _ = return $ Value $ Bool False +isTensor' _ = return $ Value $ Bool False isTensorWithIndex :: EgisonValue -> Bool isTensorWithIndex (TensorData (Tensor _ _ (_:_))) = True -isTensorWithIndex _ = False +isTensorWithIndex _ = False isTensorWithIndex' :: PrimitiveFunc isTensorWithIndex' (Value val) = return $ Value $ Bool $ isTensorWithIndex val -isTensorWithIndex' _ = return $ Value $ Bool False +isTensorWithIndex' _ = return $ Value $ Bool False isFloat' :: PrimitiveFunc isFloat' (Value (Float _ 0)) = return $ Value $ Bool True -isFloat' _ = return $ Value $ Bool False +isFloat' _ = return $ Value $ Bool False isComplex' :: PrimitiveFunc isComplex' (Value (Float _ _)) = return $ Value $ Bool True -isComplex' _ = return $ Value $ Bool False +isComplex' _ = return $ Value $ Bool False isChar' :: PrimitiveFunc isChar' (Value (Char _)) = return $ Value $ Bool True -isChar' _ = return $ Value $ Bool False +isChar' _ = return $ Value $ Bool False isString' :: PrimitiveFunc isString' (Value (String _)) = return $ Value $ Bool True -isString' _ = return $ Value $ Bool False +isString' _ = return $ Value $ Bool False isCollection' :: PrimitiveFunc -isCollection' (Value (Collection _)) = return $ Value $ Bool True +isCollection' (Value (Collection _)) = return $ Value $ Bool True isCollection' (Intermediate (ICollection _)) = return $ Value $ Bool True -isCollection' _ = return $ Value $ Bool False +isCollection' _ = return $ Value $ Bool False isArray' :: PrimitiveFunc -isArray' (Value (Array _)) = return $ Value $ Bool True +isArray' (Value (Array _)) = return $ Value $ Bool True isArray' (Intermediate (IArray _)) = return $ Value $ Bool True -isArray' _ = return $ Value $ Bool False +isArray' _ = return $ Value $ Bool False isHash' :: PrimitiveFunc -isHash' (Value (IntHash _)) = return $ Value $ Bool True -isHash' (Value (StrHash _)) = return $ Value $ Bool True +isHash' (Value (IntHash _)) = return $ Value $ Bool True +isHash' (Value (StrHash _)) = return $ Value $ Bool True isHash' (Intermediate (IIntHash _)) = return $ Value $ Bool True isHash' (Intermediate (IStrHash _)) = return $ Value $ Bool True -isHash' _ = return $ Value $ Bool False +isHash' _ = return $ Value $ Bool False readUTF8File :: FilePath -> IO String readUTF8File name = do @@ -1960,8 +1933,6 @@ varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is where f :: Index () -> Index String - f (Superscript ()) = Superscript "" - f (Subscript ()) = Subscript "" + f (Superscript ()) = Superscript "" + f (Subscript ()) = Subscript "" f (SupSubscript ()) = SupSubscript "" - -makeLenses ''MatchingStates diff --git a/hs-src/Language/Egison/Util.hs b/hs-src/Language/Egison/Util.hs --- a/hs-src/Language/Egison/Util.hs +++ b/hs-src/Language/Egison/Util.hs @@ -8,14 +8,14 @@ module Language.Egison.Util (getEgisonExpr, getEgisonExprOrNewLine, completeEgison) where -import Data.List -import Text.Regex.TDFA -import System.Console.Haskeline hiding (handle, catch, throwTo) -import Control.Monad.Except (liftIO) +import Control.Monad.Except (liftIO) +import Data.List +import System.Console.Haskeline hiding (catch, handle, throwTo) +import Text.Regex.TDFA -import Language.Egison.Types -import Language.Egison.Parser as Parser -import Language.Egison.ParserNonS as ParserNonS +import Language.Egison.Parser as Parser +import Language.Egison.ParserNonS as ParserNonS +import Language.Egison.Types -- |Get Egison expression from the prompt. We can handle multiline input. getEgisonExpr :: Bool -> String -> InputT IO (Maybe (String, EgisonTopExpr)) @@ -25,20 +25,20 @@ getEgisonExpr' isSExpr prompt prev = do mLine <- case prev of "" -> getInputLine prompt - _ -> getInputLine $ take (length prompt) (repeat ' ') + _ -> getInputLine $ replicate (length prompt) ' ' case mLine of Nothing -> return Nothing - Just [] -> do + Just [] -> if null prev then getEgisonExpr isSExpr prompt else getEgisonExpr' isSExpr prompt prev Just line -> do let input = prev ++ line case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of - Left err | show err =~ "unexpected end of input" -> do + Left err | show err =~ "unexpected end of input" -> getEgisonExpr' isSExpr prompt $ input ++ "\n" Left err -> do - liftIO $ putStrLn $ show err + liftIO $ print err getEgisonExpr isSExpr prompt Right topExpr -> return $ Just (input, topExpr) @@ -50,33 +50,33 @@ getEgisonExprOrNewLine' isSExpr prompt prev = do mLine <- case prev of "" -> getInputLine prompt - _ -> getInputLine $ take (length prompt) (repeat ' ') + _ -> getInputLine $ replicate (length prompt) ' ' case mLine of Nothing -> return $ Left Nothing Just [] -> return $ Left $ Just "" Just line -> do let input = prev ++ line case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of - Left err | show err =~ "unexpected end of input" -> do + Left err | show err =~ "unexpected end of input" -> getEgisonExprOrNewLine' isSExpr prompt $ input ++ "\n" Left err -> do - liftIO $ putStrLn $ show err + liftIO $ print err getEgisonExprOrNewLine isSExpr prompt Right topExpr -> return $ Right (input, topExpr) -- |Complete Egison keywords completeEgison :: Monad m => CompletionFunc m -completeEgison arg@((')':_), _) = completeParen arg -completeEgison arg@(('>':_), _) = completeParen arg -completeEgison arg@((']':_), _) = completeParen arg -completeEgison arg@(('}':_), _) = completeParen arg -completeEgison arg@(('(':_), _) = (completeWord Nothing " \t<>[]{}$," completeAfterOpenParen) arg -completeEgison arg@(('<':_), _) = (completeWord Nothing " \t()[]{}$," completeAfterOpenCons) arg -completeEgison arg@((' ':_), _) = (completeWord Nothing "" completeNothing) arg -completeEgison arg@(('[':_), _) = (completeWord Nothing "" completeNothing) arg -completeEgison arg@(('{':_), _) = (completeWord Nothing "" completeNothing) arg -completeEgison arg@([], _) = (completeWord Nothing "" completeNothing) arg -completeEgison arg@(_, _) = (completeWord Nothing " \t[]{}$," completeEgisonKeyword) arg +completeEgison arg@(')':_, _) = completeParen arg +completeEgison arg@('>':_, _) = completeParen arg +completeEgison arg@(']':_, _) = completeParen arg +completeEgison arg@('}':_, _) = completeParen arg +completeEgison arg@('(':_, _) = completeWord Nothing " \t<>[]{}$," completeAfterOpenParen arg +completeEgison arg@('<':_, _) = completeWord Nothing " \t()[]{}$," completeAfterOpenCons arg +completeEgison arg@(' ':_, _) = completeWord Nothing "" completeNothing arg +completeEgison arg@('[':_, _) = completeWord Nothing "" completeNothing arg +completeEgison arg@('{':_, _) = completeWord Nothing "" completeNothing arg +completeEgison arg@([], _) = completeWord Nothing "" completeNothing arg +completeEgison arg@(_, _) = completeWord Nothing " \t[]{}$," completeEgisonKeyword arg completeAfterOpenParen :: Monad m => String -> m [Completion] completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) $ egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen @@ -90,44 +90,43 @@ completeEgisonKeyword :: Monad m => String -> m [Completion] completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords -egisonPrimitivesAfterOpenParen = map ((:) '(') $ ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "empty?", "uncons", "unsnoc", "assert", "assert-equal"] -egisonKeywordsAfterOpenParen = map ((:) '(') $ ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"] +egisonPrimitivesAfterOpenParen = map ((:) '(') ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "empty?", "uncons", "unsnoc", "assert", "assert-equal"] +egisonKeywordsAfterOpenParen = map ((:) '(') ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"] ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "sort", "intersperse", "intercalate", "split", "split/m"] egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"] -egisonKeywordsInNeutral = ["something"] - ++ ["bool", "string", "integer", "nats", "primes"] +egisonKeywordsInNeutral = "something" : ["bool", "string", "integer", "nats", "primes"] egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral completeParen :: Monad m => CompletionFunc m -completeParen (lstr, _) = case (closeParen lstr) of - Nothing -> return (lstr, []) - Just paren -> return (lstr, [(Completion paren paren False)]) +completeParen (lstr, _) = case closeParen lstr of + Nothing -> return (lstr, []) + Just paren -> return (lstr, [Completion paren paren False]) closeParen :: String -> Maybe String closeParen str = closeParen' 0 $ removeCharAndStringLiteral str removeCharAndStringLiteral :: String -> String removeCharAndStringLiteral [] = [] -removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':(removeCharAndStringLiteral str) +removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':removeCharAndStringLiteral str removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str -removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':(removeCharAndStringLiteral str) +removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':removeCharAndStringLiteral str removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str -removeCharAndStringLiteral (c:str) = c:(removeCharAndStringLiteral str) +removeCharAndStringLiteral (c:str) = c:removeCharAndStringLiteral str removeCharAndStringLiteral' :: String -> String -removeCharAndStringLiteral' [] = [] -removeCharAndStringLiteral' ('"':'\\':str) = removeCharAndStringLiteral' str -removeCharAndStringLiteral' ('"':str) = removeCharAndStringLiteral str +removeCharAndStringLiteral' [] = [] +removeCharAndStringLiteral' ('"':'\\':str) = removeCharAndStringLiteral' str +removeCharAndStringLiteral' ('"':str) = removeCharAndStringLiteral str removeCharAndStringLiteral' ('\'':'\\':str) = removeCharAndStringLiteral' str -removeCharAndStringLiteral' ('\'':str) = removeCharAndStringLiteral str -removeCharAndStringLiteral' (_:str) = removeCharAndStringLiteral' str +removeCharAndStringLiteral' ('\'':str) = removeCharAndStringLiteral str +removeCharAndStringLiteral' (_:str) = removeCharAndStringLiteral' str closeParen' :: Integer -> String -> Maybe String -closeParen' _ [] = Nothing -closeParen' 0 ('(':_) = Just ")" -closeParen' 0 ('<':_) = Just ">" -closeParen' 0 ('[':_) = Just "]" -closeParen' 0 ('{':_) = Just "}" +closeParen' _ [] = Nothing +closeParen' 0 ('(':_) = Just ")" +closeParen' 0 ('<':_) = Just ">" +closeParen' 0 ('[':_) = Just "]" +closeParen' 0 ('{':_) = Just "}" closeParen' n ('(':str) = closeParen' (n - 1) str closeParen' n ('<':str) = closeParen' (n - 1) str closeParen' n ('[':str) = closeParen' (n - 1) str @@ -136,4 +135,4 @@ closeParen' n ('>':str) = closeParen' (n + 1) str closeParen' n (']':str) = closeParen' (n + 1) str closeParen' n ('}':str) = closeParen' (n + 1) str -closeParen' n (_:str) = closeParen' n str +closeParen' n (_:str) = closeParen' n str diff --git a/lib/core/order.egi b/lib/core/order.egi --- a/lib/core/order.egi +++ b/lib/core/order.egi @@ -36,12 +36,12 @@ (if (gt? x y) x y))) (define $min/fn - (lambda [$compare $x $y] - (if (eq? (compare x y) ) x y))) + (lambda [$f $xs] + (foldl 2#(if (eq? (f %1 %2) ) %1 %2) (car xs) (cdr xs)))) (define $max/fn - (lambda [$compare $x $y] - (if (eq? (compare x y) ) x y))) + (lambda [$f $xs] + (foldl 2#(if (eq? (f %1 %2) ) %1 %2) (car xs) (cdr xs)))) (define $min (cambda $xs (foldl b.min (car xs) (cdr xs)))) (define $max (cambda $xs (foldl b.max (car xs) (cdr xs)))) diff --git a/lib/math/algebra/matrix.egi b/lib/math/algebra/matrix.egi --- a/lib/math/algebra/matrix.egi +++ b/lib/math/algebra/matrix.egi @@ -97,6 +97,12 @@ [(map 1#(lambda [$i] (nth i %1)) es) (map 1#(lambda [$i] (nth i %1)) os)]))) +(define $even-and-odd-permutations0 + (lambda [$n] + (let {[[$es $os] (even-and-odd-permutations' n)]} + [(map 1#(lambda [$i] (nth (+ i 1) (map (- $ 1) %1))) es) + (map 1#(lambda [$i] (nth (+ i 1) (map (- $ 1) %1))) os)]))) + (define $even-and-odd-permutations' (lambda [$n] (match n integer diff --git a/lib/math/algebra/tensor.egi b/lib/math/algebra/tensor.egi --- a/lib/math/algebra/tensor.egi +++ b/lib/math/algebra/tensor.egi @@ -28,7 +28,7 @@ (define $. (cambda $xs (match xs (list something) - {[> (capply `. xs)] + {;[> (capply `. xs)] [_ (foldl b.. (car xs) (cdr xs))]}))) (define $T.+ diff --git a/sample/dp.egi b/sample/dp.egi new file mode 100644 --- /dev/null +++ b/sample/dp.egi @@ -0,0 +1,43 @@ +(define $delete-literals + (lambda [$ls $cnf] + (map (lambda [$c] (match-all [c ls] [(multiset integer) (multiset integer)] + [[ !] l])) + cnf))) + +(define $delete-clauses-with + (lambda [$ls $cnf] + (match-all [ls cnf] [(multiset integer) (multiset (multiset integer))] + [{[# ] + ![ ]} + c]))) + +(define $assign-true + (lambda [$l $cnf] + (delete-literals {(neg l)} (delete-clauses-with {l} cnf)))) + +(define $resolve-on + (lambda [$v $cnf] + (match-all cnf (multiset (multiset integer)) + [{ + + _>> + ![ ]} + (unique {@xs @ys})]))) + +(define $dp + (lambda [$vars $cnf] + (match [vars cnf] [(multiset integer) (multiset (multiset integer))] + {[[_ ] #t] + [[_ _>] #f] + [[_ > _>] (dp (delete (abs l) vars) (assign-true l cnf))] + [[ ! _>] (dp vs (assign-true v cnf))] + [[ ! _>] (dp vs (assign-true (neg v) cnf))] + [[ _] (dp vs {@(resolve-on v cnf) @(delete-clauses-with {v (neg v)} cnf)})]}))) + +(dp {1} {{1}}) ; #t +(dp {1} {{1} {-1}}) ; #f +(dp {1 2 3} {{1 2} {-1 3} {1 -3}}) ; #t +(dp {1 2} {{1 2} {-1 -2} {1 -2}}) ; #t +(dp {1 2} {{1 2} {-1 -2} {1 -2} {-1 2}}) ; #f +(dp {1 2 3 4 5} {{-1 -2 3} {-1 -2 -3} {1 2 3 4} {-4 -2 3} {5 1 2 -3} {-3 1 -5} {1 -2 3 4} {1 -2 -3 5}}) ; #t +(dp {1 2} {{-1 -2} {1}}) ; #t diff --git a/sample/math/geometry/ThurstonManifold.egi b/sample/math/geometry/ThurstonManifold.egi deleted file mode 100644 --- a/sample/math/geometry/ThurstonManifold.egi +++ /dev/null @@ -1,85 +0,0 @@ -(define $x~ [| θ₁ θ₂ θ₃ θ₄ |]) - -(define $g__ - [|[| 1 0 0 0 |] - [| 0 1 0 0 |] - [| 0 0 (/ κ (sqrt β)) (/ (* -1 θ₂ κ) (sqrt β)) |] - [| 0 0 (/ (* -1 θ₂ κ) (sqrt β)) (/ (* '(+ 1 θ₂) κ) (sqrt β)) |]|]) - -;(define $g~~ (M.inverse g_#_#)) -(define $g~~ - [|[| 1 0 0 0 |] - [| 0 1 0 0 |] - [| 0 0 (/ '(+ 1 θ₂) (* κ (sqrt β))) (/ θ₂ (* (sqrt β) κ)) |] - [| 0 0 (/ θ₂ (* (sqrt β) κ)) (/ 1 (* (sqrt β) κ)) |]|]) - -(define $β '(+ 1 θ₂ (* -1 (** θ₂ 2)))) -;(define $β (function [θ₂])) - -(define $Γ~c_a_b - (. (/ 1 2) - g~c~e - (+ (∂/∂ g_b_e x~a) - (∂/∂ g_a_e x~b) - (* -1 (∂/∂ g_a_b x~e))))) -Γ~1_#_# -Γ~2_#_# - -(define $R_i_j_k~l - (with-symbols {a} - (+ (- (∂/∂ Γ~l_j_k x~i) (∂/∂ Γ~l_i_k x~j)) - (- (. Γ~l_i_a Γ~a_j_k) (. Γ~l_j_a Γ~a_i_k))))) - -(define $J__ - [|[| 0 1 0 0 |] - [| -1 0 0 0 |] - [| 0 0 0 κ |] - [| 0 0 (* -1 κ) 0 |]|]) - -(define $J_a~c (. J_a_b g~b~c)) - -(define $∇J_a_b_m - (with-symbols {n} - (- (∂/∂ J_a_b x~m) - (. Γ~n_m_a J_n_b) - (. Γ~n_m_b J_a_n)))) - -(define $∇J_a_b~c - (with-symbols {n} - (. ∇J_a_b_m g~m~c))) - -(define $δ - (generate-tensor - (match-lambda [integer integer] - {[[$n ,n] 1] - [[_ _] 0]}) - {5 5})) - -(define $R'___~ - (generate-tensor - (match-lambda [integer integer integer integer] - { - [[,1 ,1 _ _] 0] - [[_ _ ,1 ,1] 0] - [[,1 $b ,1 $d] (* -1 p^2 δ~(- b 1)_(- d 1))] - [[$a ,1 ,1 $d] (* p^2 δ~(- a 1)_(- d 1))] ; complemented by Egi - [[,1 $b $c ,1] (* -1 p^2 g_(- b 1)_(- c 1))] - [[$a ,1 $c ,1] (* p^2 g_(- a 1)_(- c 1))] ; complemented by Egi - [[,1 $b $c $d] (* -1 p ∇J_(- b 1)_(- c 1)_(- d 1))] - [[$a ,1 $c $d] (* p ∇J_(- a 1)_(- c 1)~(- d 1))] ; complemented by Egi - [[$a $b ,1 $d] (* -1 p ∇J_(- a 1)_(- b 1)~(- d 1))] - [[$a $b $c ,1] (* p ∇J_(- a 1)_(- b 1)_(- c 1))] - [[$a $b $c $d] (+ R_(- a 1)_(- b 1)_(- c 1)~(- d 1) - (* -1 p^2 J_(- b 1)_(- c 1) J_(- a 1)~(- d 1)) - (* p^2 J_(- a 1)_(- c 1) J_(- b 1)~(- d 1)) - (* 2 p^2 J_(- a 1)_(- b 1) J_(- c 1)~(- d 1)))] - }) - {5 5 5 5})) - -(define $S - (with-symbols {i j k} - (let {[[$es $os] (even-and-odd-permutations 5)]} - (- (sum (map (lambda [$σ] (debug (. R'_(σ 1)_j_1~i R'_(σ 2)_(σ 3)_k~j R'_(σ 4)_(σ 5)_i~k))) es)) - (sum (map (lambda [$σ] (debug (. R'_(σ 1)_j_1~i R'_(σ 2)_(σ 3)_k~j R'_(σ 4)_(σ 5)_i~k))) os)))))) - -S diff --git a/sample/math/geometry/ThurstonManifold2.egi b/sample/math/geometry/ThurstonManifold2.egi deleted file mode 100644 --- a/sample/math/geometry/ThurstonManifold2.egi +++ /dev/null @@ -1,54 +0,0 @@ -(define $N 3) - -(define $J - (generate-tensor - (match-lambda [integer integer] - {[[$i ,(+ i (* 2 N))] 1] - [[$i ,(- i (* 2 N))] -1] - [[_ _] 0]}) - {(* 4 N) (* 4 N)})) - -J - -(define $δ - (generate-tensor - (match-lambda [integer integer] - {[[$n ,n] 1] - [[_ _] 0]}) - {(* 4 N) (* 4 N)})) - -δ - -(define $g δ) - -g - -(define $T_a_b_c~d - (+ (* -1 (. J_b_c J_a~d)) - (. J_a_c J_b~d) - (* 2 (. J_a_b J_c~d)))) - -T_1_1_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~# -T_1_2_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 1 |] [| 0 0 -1 0 |] |]_#~# -T_1_3_#~#;[| [| 0 0 3 0 |] [| 0 0 0 2 |] [| -3 0 0 0 |] [| 0 -2 0 0 |] |]_#~# -T_1_4_#~#;[| [| 0 0 0 0 |] [| 0 0 1 0 |] [| 0 -1 0 0 |] [| 0 0 0 0 |] |]_#~# -T_2_1_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 -1 |] [| 0 0 1 0 |] |]_#~# -T_2_2_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~# -T_2_3_#~#;[| [| 0 0 0 1 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| -1 0 0 0 |] |]_#~# -T_2_4_#~#;[| [| 0 0 2 0 |] [| 0 0 0 3 |] [| -2 0 0 0 |] [| 0 -3 0 0 |] |]_#~# -T_3_1_#~#;[| [| 0 0 -3 0 |] [| 0 0 0 -2 |] [| 3 0 0 0 |] [| 0 2 0 0 |] |]_#~# -T_3_2_#~#;[| [| 0 0 0 -1 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 1 0 0 0 |] |]_#~# -T_3_3_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~# -T_3_4_#~#;[| [| 0 1 0 0 |] [| -1 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~# -T_4_1_#~#;[| [| 0 0 0 0 |] [| 0 0 -1 0 |] [| 0 1 0 0 |] [| 0 0 0 0 |] |]_#~# -T_4_2_#~#;[| [| 0 0 -2 0 |] [| 0 0 0 -3 |] [| 2 0 0 0 |] [| 0 3 0 0 |] |]_#~# -T_4_3_#~#;[| [| 0 -1 0 0 |] [| 1 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~# -T_4_4_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~# - -(define $S' - (with-symbols {i j k} - (let {[[$es $os] (even-and-odd-permutations (* 4 N))]} - (- (sum (map (lambda [$σ] (let {[$x (debug [0 (map 1#(σ %1) (between 1 (* 4 N))) (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k (* 2 N))]~[a_(- k 1)]) (between 1 (* 2 N))))])]} (3#%3 x))) es)) - (sum (map (lambda [$σ] (let {[$x (debug [1 (map 1#(σ %1) (between 1 (* 4 N))) (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k (* 2 N))]~[a_(- k 1)]) (between 1 (* 2 N))))])]} (3#%3 x))) os)))))) - -S' diff --git a/sample/math/geometry/ThurstonManifold3.egi b/sample/math/geometry/ThurstonManifold3.egi deleted file mode 100644 --- a/sample/math/geometry/ThurstonManifold3.egi +++ /dev/null @@ -1,37 +0,0 @@ -(define $N 3) - -(define $J - (generate-tensor - (match-lambda [integer integer] - {[[$i ,(+ i N)] 1] - [[$i ,(- i N)] -1] - [[_ _] 0]}) - {(* 2 N) (* 2 N)})) - -J - -(define $δ - (generate-tensor - (match-lambda [integer integer] - {[[$n ,n] 1] - [[_ _] 0]}) - {(* 2 N) (* 2 N)})) - -δ - -(define $g δ) - -g - -(define $T_a_b_c~d - (+ (* -1 (. J_b_c J_a~d)) - (. J_a_c J_b~d) - (* 2 (. J_a_b J_c~d)))) - -(define $S' - (with-symbols {i j k} - (let {[[$es $os] (even-and-odd-permutations (* 2 N))]} - (- (sum (map (lambda [$σ] (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k N)]~[a_(- k 1)]) (between 1 N)))) es)) - (sum (map (lambda [$σ] (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k N)]~[a_(- k 1)]) (between 1 N)))) os)))))) - -S' diff --git a/sample/order.egi b/sample/order.egi new file mode 100644 --- /dev/null +++ b/sample/order.egi @@ -0,0 +1,23 @@ +(define $lexical-compare + (lambda [$xs $ys] + (match [xs ys] [(list ordering) (list ordering)] + {[[ ] ] + [[ _] ] + [[_ ] ] + [[ ] (lexical-compare xs' ys')] + [[ ] (compare x y)]}))) + + +(define $lexical-compare + (lambda [$xs $ys] + (match [xs ys] [(list ordering) (list ordering)] + {[(loop $i [1 _] + {[ ] + @...} + (& ![ ] + [$xs' $ys'])) + (match [xs' ys'] [(list ordering) (list ordering)] + {[[ ] ] + [[ _] ] + [[_ ] ] + [[ ] (compare x y)]})]}))) diff --git a/sample/salesman2.egi b/sample/salesman2.egi new file mode 100644 --- /dev/null +++ b/sample/salesman2.egi @@ -0,0 +1,34 @@ +;;; +;;; Travelling Salesman Problem +;;; + +(define $station string) +(define $price integer) +(define $graph (multiset [station (multiset [station price])])) + +(define $graph-data + {["Berlin" { ["St. Louis" 14] ["Oxford" 2] ["Nara" 14] ["Vancouver" 13]}] + ["St. Louis" {["Berlin" 14] ["Oxford" 12] ["Nara" 18] ["Vancouver" 6]}] + ["Oxford" {["Berlin" 2] ["St. Louis" 12] ["Nara" 15] ["Vancouver" 10]}] + ["Nara" {["Berlin" 14] ["St. Louis" 18] ["Oxford" 15] ["Vancouver" 12]}] + ["Vancouver" {["Berlin" 13] ["St. Louis" 6] ["Oxford" 10] ["Nara" 12] }]}) + + +(define $trips ; List up all routes that visit each city exactly once and return to Tokyo + (match-all graph-data graph + [] + (loop $i [2 4] + ] + ...> + ] + _>)> + [(sum (map (lambda [$i] p_i) (between 1 5))) + s]])) + +(define $main + (lambda [$args] + (do {[(print "Route list:")] + [(each (compose show print) trips)] + [(write "Lowest price:")] + [(print (show (min (map (lambda [$x $y] x) trips))))]}))) +