egison 2.3.7 → 2.3.8
raw patch · 7 files changed
+157/−144 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- egison.cabal +1/−1
- etc/template.hs +11/−8
- hs-src/Compiler/egisonc.hs +82/−45
- lib/core/number.egi +1/−1
- lib/graph.egi +12/−0
- sample/collection-test.egi +49/−88
- sample/icfpc2012/mine.egi +1/−1
egison.cabal view
@@ -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.
etc/template.hs view
@@ -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 ()
hs-src/Compiler/egisonc.hs view
@@ -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"
lib/core/number.egi view
@@ -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]
lib/graph.egi view
@@ -16,6 +16,18 @@ {[$tgt {tgt}]}] })) +(define $all-paths+ (lambda [$g $s $e]+ (let {[$n (size g)]}+ (match-all g Graph+ [(| <cons <node ,s <cons ,e _> _> $rest>+ <cons <node ,s <cons $a_2 _> _>+ (loop $l $i (between 3 (- n 1))+ (| <cons <node ,a_(- i 1) <cons ,e _> _> $rest>+ <cons <node ,a_(- i 1) <cons $a_i _> _> l>)+ <cons <node ,a_(- n 1) <cons ,e _> $rest>>)>)+ [{s @(loop $l $i (between 2 (- n (size rest))) {a_i @l} {e})}]]))))+ (define $Graph (Multiset NodeInfo)) (define $hamilton-cycle
sample/collection-test.egi view
@@ -1,3 +1,14 @@+(test (match-all {1 2 3 4 5} (List Integer) [<join ,{1 2} $xs> xs]))++(test (match-all {[1 2] [1 2]} (List [Integer Integer])+ [<cons [$a $b] _> [a b]]))+++;; match Multiset+(test (match-all {1 2 3 4 5} (Multiset Integer)+ [<cons $m <cons $n _>> [m n]]))++;; match a collection of collections (test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer)) [<cons <cons $x _> <cons <cons $y _>@@ -5,6 +16,7 @@ <nil>>>> [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)) [<cons <cons $n _> <cons <cons ,n _>@@ -12,20 +24,39 @@ <nil>>>> n])) -(test (match-all {1 2 3 4 5} (Multiset Integer)- [<cons $m <cons $n _>> [m n]]))-+;; pattern as first class object (test (let {[$pat <cons ,1 <nil>>]} (match {1} (Multiset Integer) {[pat <ok>] [_ <not-ok>]}))) +;; Or-pattern test1+(test (match {} (Multiset Integer)+ {[(| <nil> <cons ,1 <nil>>) <ok>]+ [_ <not-ok>]}))++;; Or-pattern test2 (test (match {1} (Multiset Integer) {[(| <nil> <cons ,1 <nil>>) <ok>] [_ <not-ok>]})) -(test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]])) +(test (match-all {1 2 3 4 5 6 7 1 3 5 7} (Multiset Integer)+ [<cons $x ^<cons ,x _>> x]))++(test (match-all {{1 2 3} {2 3 4} {1}} (Multiset (Multiset Integer))+ [<cons <cons $x ^<cons ,x _>>+ <cons ^<cons ,x _>+ <cons ^<cons ,x _>+ <nil>>>>+ x]))++(test (match-all {{1 2 3} {2 3 4}} (Multiset (Multiset Integer))+ [<cons <cons $x ^<cons ,x _>>+ <cons ^<cons ,x _>+ <nil>>>+ x]))+ (test (match-all {1 2 3} (List Integer) [<join $hs $ts> [hs ts]])) @@ -41,34 +72,14 @@ (test (match-all {1 2 3} (List Integer) [<join $hs <cons $x $ts>> [hs x ts]])) +;; noij+(test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))+ (test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>})) (test (subcollections {<x> <y> <z>})) -(test (poker-hands {<card <club> 4>- <card <club> 2>- <card <club> 5>- <card <club> 1>- <card <club> 3>}))--(test (poker-hands {<card <diamond> 1>- <card <club> 2>- <card <club> 1>- <card <heart> 1>- <card <diamond> 2>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 2>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 10>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))-+;; Cut-pattern (test (match {2 7 7 2 7} (Multiset Integer) {[<cons $m <cons ,m@@ -79,20 +90,7 @@ <ok>] [_ <ko>]})) -(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)- [<cons $x- <cons $y- <cons $z- <nil>>>>- [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)- [<cons $x- <cons $y- <cons $z- !<nil>>>>- [x y z]]))-+;; Value-pattern (test (match {5 2 1 3 4} (Multiset Integer) {[<cons $n <cons ,(- n 1)@@ -103,59 +101,19 @@ <ok>] [_ <ko>]})) -(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)))- {[]}- {})]}]- [<nil> []- {[$tgt (match-all tgt (List a) [<nil> []])]}]- [<cons _ _> [a (List a)]- {[$tgt {@(match-all tgt (List a) [<cons $x $xs> [x xs]])- @(match-all (reverse tgt) (List a) [<cons $x $xs> [x xs]])}]}]- [<join _ _> [(List a) (List a)]- {[$tgt {@(match-all tgt (List a) [<join $xs $ys> [xs ys]])- @(match-all (reverse tgt) (List a) [<join $xs $ys> [xs ys]])}]}]- [_ [Something]- {[$tgt {tgt}]}]- })))--(test (match-all {1 2 3} (Stick Integer) [<cons $x $xs> [x xs]]))-(test (match-all {1 2 3} (Stick Integer) [<join $xs $ys> [xs ys]]))-(test (match-all {1 2 3 4} (Stick Integer) [<join $xs <cons $w $ys>> [xs w ys]]))-(test (match-all {1 2 3} (Stick Integer) [,{3 2 1} <ok>]))--(test (match-all {1 2 3 4 5} (List Integer)- [<join _ <cons $m <join _ <cons $n _>>>> [m n]]))- (test (match-all {1 2 3 4} (List Integer) [<join _ <join $ns _>> ns])) -(define $combination- (lambda [$xs $k]- (match k Nat- {[<o> {{}}]- [<s $k1>- (concat (match-all xs (List Something)- [<join _ <cons $x $rs>>- (map (lambda [$ys]- {x @ys})- (combination rs k1))]))]}))) -(test (combination {1 2 3 4 5} 3))--<join _ <cons $n_1 ... <join _ <cons $n_k _>> ... >>+;; pattern macro+(define $pair+ (macro [$s $pat]+ <cons $`s <cons ,`s pat>>)) -(... [$n Integer (squence 1 k (lambda [$i] (+ i 1)))]- <join _ <cons $n_i ...>> _)+(test (match-all {1 2 3 1 2} (Multiset Integer)+ [(pair %k _) k])) (define $loop-pat (lambda [$k $i]@@ -184,3 +142,6 @@ [_ <ko>]}))) (test (isStraight? {1 2}))++;; comparison of large list+(test (match-all (between 1 2000) (List Integer) [<join ,(between 1 1000) <cons $x _>> x]))
sample/icfpc2012/mine.egi view
@@ -354,7 +354,7 @@ (generate-array (lambda [$x $y] (match mine Mine- {[(& <cons ,[x y] <robot <normal>>>+ {[(& <cons ,[x y] <robot _>> <cons ,[x (+ y 1)] <rock ,#t>>) <robot <broken>>] [<cons ,[x y] $tile> tile]