diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.3.7 +Version: 2.3.8 Synopsis: An Interpreter for the Programming Language Egison Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility. diff --git a/etc/template.hs b/etc/template.hs --- a/etc/template.hs +++ b/etc/template.hs @@ -1,11 +1,11 @@ module Main where import Language.Egison.Core -- Egison Interpreter import Language.Egison.Types -- Egison data types -import Language.Egison.Variables -- Egison variable operations -import Language.Egison.Parser -- Egison variable operations +--import Language.Egison.Variables -- Egison variable operations +--import Language.Egison.Parser -- Egison variable operations --import Control.Monad (when) import Control.Monad.Error -import System.IO +--import System.IO import System.Environment @@ -13,8 +13,11 @@ main = do args <- getArgs env <- primitiveBindings - _ <- loadLibraries env - _ <- runIOThrows $ liftM concat $ mapM (evalTopExpr env) topExprs - _ <- runIOThrows $ evalTopExpr env $ Execute args - return () - + ret1 <- runIOThrows $ liftM concat $ mapM (evalTopExpr env) topExprs + case ret1 of + Just errMsg -> putStrLn errMsg + _ -> do + ret2 <- runIOThrows $ evalTopExpr env $ Execute args + case ret2 of + Just errMsg -> putStrLn errMsg + _ -> return () diff --git a/hs-src/Compiler/egisonc.hs b/hs-src/Compiler/egisonc.hs --- a/hs-src/Compiler/egisonc.hs +++ b/hs-src/Compiler/egisonc.hs @@ -2,13 +2,12 @@ import Language.Egison.Core import Language.Egison.Types import Language.Egison.Parser ---import Language.Egison.Variables import Control.Monad.Error import System.Cmd (system) import System.Console.GetOpt import System.FilePath (dropExtension) import System.Environment -import System.Directory (copyFile, removeFile) +import System.Directory (doesFileExist, copyFile, removeFile) import System.Exit (ExitCode (..), exitWith, exitFailure) import System.IO import Paths_egison @@ -20,92 +19,130 @@ main = do args <- getArgs let (actions, nonOpts, _) = getOpt Permute options args - opts <- foldl (>>=) (return defaultOptions) actions - let Options {optOutput = output} = opts - if null nonOpts - then showUsage - else do - let inFile = nonOpts !! 0 - outExec = case output of - Just outFile -> outFile - Nothing -> dropExtension inFile - process inFile outExec + let opts = foldl (flip id) defaultOptions actions + case opts of + Options {optShowHelp = True} -> printHelp + Options {optShowVersion = True} -> printVersionNumber + Options {optOutput = output, optProf = prof} -> + if null nonOpts + then showUsage + else do + let inFile = nonOpts !! 0 + outExec = case output of + Just outFile -> outFile + Nothing -> dropExtension inFile + process prof inFile outExec --- |Data type to handle command line options that take parameters data Options = Options { - optOutput :: Maybe String -- Executable file to write + optShowVersion :: Bool, + optShowHelp :: Bool, + optOutput :: Maybe String, + optProf :: Bool } --- |Print a usage message showUsage :: IO () showUsage = do putStrLn "egisonc: no input files" --- |Default values for the command line options defaultOptions :: Options defaultOptions = Options { - optOutput = Nothing + optShowVersion = False, + optShowHelp = False, + optOutput = Nothing, + optProf = False } -options :: [OptDescr (Options -> IO Options)] +options :: [OptDescr (Options -> Options)] options = [ - Option ['V'] ["version"] (NoArg showVersionNumber) "show version number", - Option ['h', '?'] ["help"] (NoArg showHelp) "show usage information", - Option ['o'] ["output"] (ReqArg writeExec "FILE") "output file to write" + Option ['v', 'V'] ["version"] + (NoArg (\opts -> opts {optShowVersion = True})) + "show version number", + Option ['h', '?'] ["help"] + (NoArg (\opts -> opts {optShowHelp = True})) + "show usage information", + Option ['o'] ["output"] + (ReqArg (\out opts -> opts {optOutput = Just out}) + "FILE") + "output file to write", + Option ['p'] ["prof"] + (NoArg (\opts -> opts {optProf = True})) + "use profiling system" ] --- |Print version information -showVersionNumber :: Options -> IO Options -showVersionNumber _ = do +printVersionNumber :: IO () +printVersionNumber = do putStrLn egisonVersion exitWith ExitSuccess -showHelp :: Options -> IO Options -showHelp _ = do +printHelp :: IO () +printHelp = do putStrLn "Usage: egisonc [options] file" putStrLn "" putStrLn "Options:" putStrLn " --help Display this information" putStrLn " --version Display egison version information" putStrLn " --output filename Write executable to the given filename" + putStrLn " --prof Make use of GHC profiling system" putStrLn "" exitWith ExitSuccess --- |Determine executable file to write. --- This version just takes a name from the command line option -writeExec arg opt = return opt { optOutput = Just arg } - --- |High level code to compile the given file -process :: String -> String -> IO () -process inFile outExec = do +process :: Bool -> String -> String -> IO () +process prof inFile outExec = do result <- (runIOThrows $ liftM show $ createHaskellFile inFile) case result of Just errMsg -> putStrLn errMsg - _ -> compileHaskellFile outExec - -replaceTabToSpace :: String -> String -replaceTabToSpace [] = [] -replaceTabToSpace ('\t':cs) = ' ':(replaceTabToSpace cs) -replaceTabToSpace (c:cs) = c:(replaceTabToSpace cs) + _ -> compileHaskellFile prof outExec +appendLoadExprForCoreLibraries :: [TopExpr] -> [TopExpr] +appendLoadExprForCoreLibraries topExprs = [(Load "lib/core/base.egi"), + (Load "lib/core/number.egi"), + (Load "lib/core/collection.egi"), + (Load "lib/core/array.egi") + ] ++ topExprs + createHaskellFile :: String -> IOThrowsError () createHaskellFile inFile = do templatePath <- liftIO $ getDataFileName templateFile liftIO $ copyFile templatePath "./_tmp.hs" egisonProgram <- liftIO $ readFile inFile topExprs <- liftThrows $ readTopExprList egisonProgram + topExprs2 <- expandLoadExprs $ appendLoadExprForCoreLibraries topExprs liftIO $ appendFile "./_tmp.hs" "\ntopExprs :: [TopExpr]\n" liftIO $ appendFile "./_tmp.hs" "topExprs = " - liftIO $ appendFile "./_tmp.hs" $ show topExprs + liftIO $ appendFile "./_tmp.hs" $ show topExprs2 return () +expandLoadExprs :: [TopExpr] -> IOThrowsError [TopExpr] +expandLoadExprs [] = return [] +expandLoadExprs ((LoadFile filename):topExprs) = do + result <- liftIO $ doesFileExist filename + if result + then do + loadProgram <- liftIO $ readFile filename + loadTopExprs <- liftThrows $ readTopExprList loadProgram + rets <- expandLoadExprs topExprs + return $ loadTopExprs ++ rets + else throwError $ Default $ "File does not exist: " ++ filename +expandLoadExprs ((Load libname):topExprs) = do + filename <- liftIO (getDataFileName libname) + result <- liftIO $ doesFileExist filename + if result + then do + loadProgram <- liftIO $ readFile filename + loadTopExprs <- liftThrows $ readTopExprList loadProgram + rets <- expandLoadExprs topExprs + return $ loadTopExprs ++ rets + else throwError $ Default $ "Library does not exist: " ++ libname +expandLoadExprs (topExpr:topExprs) = do + rets <- expandLoadExprs topExprs + return $ topExpr:rets --- |Compile the intermediate haskell file using GHC -compileHaskellFile :: String -> IO() -compileHaskellFile filename = do +compileHaskellFile :: Bool -> String -> IO () +compileHaskellFile prof filename = do let ghc = "ghc" --- compileStatus <- system $ ghc ++ " " ++ " -cpp --make -package ghc -fglasgow-exts -o " ++ filename ++ " _tmp.hs" - _ <- system $ ghc ++ " -O2 -o " ++ filename ++ " _tmp.hs" + if prof + then system $ ghc ++ " -prof -auto-all -o " ++ filename ++ " _tmp.hs" + else system $ ghc ++ " -O2 -o " ++ filename ++ " _tmp.hs" removeFile "./_tmp.hs" removeFile "./_tmp.hi" removeFile "./_tmp.o" diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -122,7 +122,7 @@ (lambda [$m] (type {[,$n [] - {[$tgt (if (eq-n (mod tgt m) (mod n m)) + {[$tgt (if (eq-n? (mod tgt m) (mod n m)) {[]} {})]}] [_ [Something] diff --git a/lib/graph.egi b/lib/graph.egi --- a/lib/graph.egi +++ b/lib/graph.egi @@ -16,6 +16,18 @@ {[$tgt {tgt}]}] })) +(define $all-paths + (lambda [$g $s $e] + (let {[$n (size g)]} + (match-all g Graph + [(| _> $rest> + _> + (loop $l $i (between 3 (- n 1)) + (| _> $rest> + _> l>) + $rest>>)>) + [{s @(loop $l $i (between 2 (- n (size rest))) {a_i @l} {e})}]])))) + (define $Graph (Multiset NodeInfo)) (define $hamilton-cycle diff --git a/sample/collection-test.egi b/sample/collection-test.egi --- a/sample/collection-test.egi +++ b/sample/collection-test.egi @@ -1,3 +1,14 @@ +(test (match-all {1 2 3 4 5} (List Integer) [ xs])) + +(test (match-all {[1 2] [1 2]} (List [Integer Integer]) + [ [a b]])) + + +;; match Multiset +(test (match-all {1 2 3 4 5} (Multiset Integer) + [> [m n]])) + +;; match a collection of collections (test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer)) [ @@ -5,6 +16,7 @@ >>> [x y z]])) +;; match a collection of collections with value patterns (test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Integer)) [ @@ -12,20 +24,39 @@ >>> n])) -(test (match-all {1 2 3 4 5} (Multiset Integer) - [> [m n]])) - +;; pattern as first class object (test (let {[$pat >]} (match {1} (Multiset Integer) {[pat ] [_ ]}))) +;; Or-pattern test1 +(test (match {} (Multiset Integer) + {[(| >) ] + [_ ]})) + +;; Or-pattern test2 (test (match {1} (Multiset Integer) {[(| >) ] [_ ]})) -(test (match-all { } (List Something) [ [xs ys]])) +(test (match-all {1 2 3 4 5 6 7 1 3 5 7} (Multiset Integer) + [> x])) + +(test (match-all {{1 2 3} {2 3 4} {1}} (Multiset (Multiset Integer)) + [> + + + >>> + x])) + +(test (match-all {{1 2 3} {2 3 4}} (Multiset (Multiset Integer)) + [> + + >> + x])) + (test (match-all {1 2 3} (List Integer) [ [hs ts]])) @@ -41,34 +72,14 @@ (test (match-all {1 2 3} (List Integer) [> [hs x ts]])) +;; noij +(test (match-all { } (List Something) [ [xs ys]])) + (test ((remove-collection Suit) { } { })) (test (subcollections { })) -(test (poker-hands { 4> - 2> - 5> - 1> - 3>})) - -(test (poker-hands { 1> - 2> - 1> - 1> - 2>})) - -(test (poker-hands { 4> - 2> - 5> - 1> - 3>})) - -(test (poker-hands { 4> - 10> - 5> - 1> - 3>})) - +;; Cut-pattern (test (match {2 7 7 2 7} (Multiset Integer) {[] [_ ]})) -(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer) - [>>> - [x y z]])) - -(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer) - [>>> - [x y z]])) - +;; Value-pattern (test (match {5 2 1 3 4} (Multiset Integer) {[] [_ ]})) -(test (letrec {[$f (lambda [$x] (+ (g x) 10))] - [$g (lambda [$x] (+ x 1))]} - (f 0))) -(define $Stick - (lambda [$a] - (type - {[,$val [] - {[$tgt (if (or ((= (List a)) val tgt) - ((= (List a)) val (reverse tgt))) - {[]} - {})]}] - [ [] - {[$tgt (match-all tgt (List a) [ []])]}] - [ [a (List a)] - {[$tgt {@(match-all tgt (List a) [ [x xs]]) - @(match-all (reverse tgt) (List a) [ [x xs]])}]}] - [ [(List a) (List a)] - {[$tgt {@(match-all tgt (List a) [ [xs ys]]) - @(match-all (reverse tgt) (List a) [ [xs ys]])}]}] - [_ [Something] - {[$tgt {tgt}]}] - }))) - -(test (match-all {1 2 3} (Stick Integer) [ [x xs]])) -(test (match-all {1 2 3} (Stick Integer) [ [xs ys]])) -(test (match-all {1 2 3 4} (Stick Integer) [> [xs w ys]])) -(test (match-all {1 2 3} (Stick Integer) [,{3 2 1} ])) - -(test (match-all {1 2 3 4 5} (List Integer) - [>>> [m n]])) - (test (match-all {1 2 3 4} (List Integer) [> ns])) -(define $combination - (lambda [$xs $k] - (match k Nat - {[ {{}}] - [ - (concat (match-all xs (List Something) - [> - (map (lambda [$ys] - {x @ys}) - (combination rs k1))]))]}))) -(test (combination {1 2 3 4 5} 3)) - -> ... >> +;; pattern macro +(define $pair + (macro [$s $pat] + >)) -(... [$n Integer (squence 1 k (lambda [$i] (+ i 1)))] - > _) +(test (match-all {1 2 3 1 2} (Multiset Integer) + [(pair %k _) k])) (define $loop-pat (lambda [$k $i] @@ -184,3 +142,6 @@ [_ ]}))) (test (isStraight? {1 2})) + +;; comparison of large list +(test (match-all (between 1 2000) (List Integer) [> x])) diff --git a/sample/icfpc2012/mine.egi b/sample/icfpc2012/mine.egi --- a/sample/icfpc2012/mine.egi +++ b/sample/icfpc2012/mine.egi @@ -354,7 +354,7 @@ (generate-array (lambda [$x $y] (match mine Mine - {[(& >> + {[(& > >) >] [ tile]