diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.2.13 +Version: 3.2.14 Synopsis: Programming language with non-linear pattern-matching against unfree data types Description: An interpreter for Egison, the programming langugage that realized non-linear pattern-matching with unfree data types. With Egison, you can represent pattern-matching with unfree data types intuitively, @@ -19,6 +19,7 @@ Data-files: lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi lib/core/string.egi lib/core/database.egi lib/core/io.egi lib/tree/xml.egi lib/math/prime.egi + sample/*.egi sample/io/*.egi sample/io/*.egi elisp/egison-mode.el source-repository head @@ -37,6 +38,7 @@ Language.Egison.Types Language.Egison.Parser Language.Egison.Primitives + Language.Egison.Util Other-modules: Paths_egison Test-Suite test diff --git a/hs-src/Interpreter/egisoni.hs b/hs-src/Interpreter/egisoni.hs --- a/hs-src/Interpreter/egisoni.hs +++ b/hs-src/Interpreter/egisoni.hs @@ -27,6 +27,7 @@ import System.Exit (ExitCode (..), exitWith, exitFailure) import System.IO import Language.Egison +import Language.Egison.Util main :: IO () main = do args <- getArgs @@ -36,20 +37,20 @@ Options {optShowHelp = True} -> printHelp Options {optShowVersion = True} -> printVersionNumber Options {optPrompt = prompt, optShowBanner = bannerFlag} -> do - case nonOpts of - [] -> do - env <- primitiveEnv >>= loadLibraries - when bannerFlag showBanner >> repl env prompt >> when bannerFlag showByebyeMessage - (file:args) -> do - case opts of - Options {optLoadOnly = True} -> do - env <- primitiveEnvNoIO >>= loadLibraries - result <- evalEgisonTopExprs env [LoadFile file] - either print (const $ return ()) result - Options {optLoadOnly = False} -> do - env <- primitiveEnv >>= loadLibraries - result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))] - either print (const $ return ()) result + case nonOpts of + [] -> do + env <- primitiveEnv >>= loadCoreLibraries + when bannerFlag showBanner >> repl env prompt >> when bannerFlag showByebyeMessage + (file:args) -> do + case opts of + Options {optLoadOnly = True} -> do + env <- primitiveEnvNoIO >>= loadCoreLibraries + result <- evalEgisonTopExprs env [LoadFile file] + either print (const $ return ()) result + Options {optLoadOnly = False} -> do + env <- primitiveEnv >>= loadCoreLibraries + result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))] + either print (const $ return ()) result data Options = Options { optShowVersion :: Bool, @@ -128,7 +129,7 @@ where settings :: MonadIO m => FilePath -> Settings m settings home = do - setComplete completeParen $ defaultSettings { historyFile = Just (home ".egison_history") } + setComplete completeEgison $ defaultSettings { historyFile = Just (home ".egison_history") } loop :: Env -> String -> String -> InputT IO () loop env prompt' rest = do @@ -150,7 +151,7 @@ Left err | show err =~ "unexpected end of input" -> do loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n" Left err | show err =~ "expecting (top-level|\"define\")" -> do - result <- liftIO $ handle onAbort $ fromEgisonM (readExpr newInput) >>= either (return . Left) (evalEgisonExpr env) + result <- liftIO $ handle onAbort $ runEgisonExpr env newInput case result of Left err | show err =~ "unexpected end of input" -> do loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n" @@ -165,73 +166,3 @@ loop env prompt "" Right env' -> loop env' prompt "" - -completeParen :: Monad m => CompletionFunc m -completeParen arg@((')':_), _) = completeParen' arg -completeParen arg@(('>':_), _) = completeParen' arg -completeParen arg@((']':_), _) = completeParen' arg -completeParen arg@(('}':_), _) = completeParen' arg -completeParen arg@(('(':_), _) = (completeWord Nothing " \t<>[]{}$," completeAfterOpenParen) arg -completeParen arg@(('<':_), _) = (completeWord Nothing " \t()[]{}$," completeAfterOpenCons) arg -completeParen arg@((' ':_), _) = (completeWord Nothing "" completeNothing) arg -completeParen arg@([], _) = (completeWord Nothing "" completeNothing) arg -completeParen arg@(_, _) = (completeWord Nothing " \t[]{}$," completeEgisonKeyword) arg - -completeAfterOpenParen :: Monad m => String -> m [Completion] -completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenParen - -completeAfterOpenCons :: Monad m => String -> m [Completion] -completeAfterOpenCons str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenCons - -completeNothing :: Monad m => String -> m [Completion] -completeNothing _ = return [] - -completeEgisonKeyword :: Monad m => String -> m [Completion] -completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords - -egisonKeywordsAfterOpenParen = map ((:) '(') $ ["define", "let", "letrec", "do", "lambda", "match-lambda", "match", "match-all", "pattern-function", "matcher", "algebraic-data-matcher", "if", "loop", "io"] - ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "empty?", "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", "simple-select", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "pfs", "pfs-n", "min", "max", "min-and-max", "power", "mod", "float", "ordering", "qsort", "intersperse", "intercalate", "split", "split/m"] -egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"] -egisonKeywordsInNeutral = ["something"] - ++ ["bool", "string", "integer", "nat", "nats", "nats0"] -egisonKeywords = 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)]) - -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 (c:str) = c:(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 - -closeParen' :: Integer -> String -> Maybe String -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 -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 + 1) str -closeParen' n ('}':str) = closeParen' (n + 1) str -closeParen' n (_:str) = closeParen' n str 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 @@ -1,26 +1,33 @@ +{- | +Module : Language.Egison +Copyright : Satoshi Egi +Licence : MIT +This is the top module of Egison. +-} + module Language.Egison ( module Language.Egison.Types , module Language.Egison.Parser , module Language.Egison.Primitives - , version - , counter --danger - , fromEgisonM - , loadLibraries - , loadPrimitives - , loadEgisonFile - , loadEgisonLibrary + -- * Eval Egison expressions , evalEgisonExpr , evalEgisonTopExpr , evalEgisonTopExprs + , runEgisonExpr , runEgisonTopExpr , runEgisonTopExprs + -- * Load Egison files + , loadCoreLibraries + , loadEgisonLibrary + , loadEgisonFile + -- * Information + , version ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad.Error -import System.IO.Unsafe (unsafePerformIO) import Data.IORef import Data.Version import qualified Paths_egison as P @@ -30,37 +37,42 @@ import Language.Egison.Primitives import Language.Egison.Core +-- |Version number version :: Version version = P.version --- Unsafe -counter :: IORef Int -counter = unsafePerformIO (newIORef 0) +-- |eval an Egison expression +evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue) +evalEgisonExpr env expr = fromEgisonM $ evalExprDeep env expr -readCounter :: IO Int -readCounter = readIORef counter +-- |eval an Egison top expression +evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env) +evalEgisonTopExpr env exprs = fromEgisonM $ evalTopExpr env exprs -updateCounter :: Int -> IO () -updateCounter = writeIORef counter +-- |eval Egison top expressions +evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env) +evalEgisonTopExprs env exprs = fromEgisonM $ evalTopExprs env exprs -modifyCounter :: FreshT IO a -> IO a -modifyCounter m = do - seed <- readCounter - (result, seed) <- runFreshT seed m - updateCounter seed - return result +-- |eval an Egison expression. Input is a Haskell string. +runEgisonExpr :: Env -> String -> IO (Either EgisonError EgisonValue) +runEgisonExpr env input = fromEgisonM $ readExpr input >>= evalExprDeep env -loadLibraries :: Env -> IO Env -loadLibraries env = do - seed <- readIORef counter - (result, seed') <- runFreshT seed $ runEgisonM $ foldM evalTopExpr env (map Load libraries) - writeIORef counter seed' - case result of +-- |eval an Egison top expression. Input is a Haskell string. +runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env) +runEgisonTopExpr env input = fromEgisonM $ readTopExpr input >>= evalTopExpr env + +-- |eval Egison top expressions. Input is a Haskell string. +runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env) +runEgisonTopExprs env input = fromEgisonM $ readTopExprs input >>= evalTopExprs env + +loadCoreLibraries :: Env -> IO Env +loadCoreLibraries env = do + ret <- evalEgisonTopExprs env $ map Load libraries + case ret of Left err -> do print . show $ err return env - Right env' -> - return env' + Right env' -> return env' where libraries :: [String] libraries = [ "lib/core/base.egi" @@ -73,29 +85,9 @@ , "lib/core/io.egi" ] -fromEgisonM :: EgisonM a -> IO (Either EgisonError a) -fromEgisonM = modifyCounter . runEgisonM - -loadPrimitives :: Env -> IO Env -loadPrimitives env = (++) <$> return env <*> primitiveEnv - loadEgisonFile :: Env -> FilePath -> IO (Either EgisonError Env) -loadEgisonFile env path = modifyCounter $ runEgisonM $ loadFile path >>= evalTopExprs env +loadEgisonFile env path = evalEgisonTopExpr env (LoadFile path) loadEgisonLibrary :: Env -> FilePath -> IO (Either EgisonError Env) -loadEgisonLibrary env path = modifyCounter $ runEgisonM $ loadLibraryFile path >>= evalTopExprs env - -evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue) -evalEgisonExpr env expr = modifyCounter $ runEgisonM $ evalExpr' env expr - -evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env) -evalEgisonTopExpr env exprs = modifyCounter $ runEgisonM $ evalTopExpr env exprs - -evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env) -evalEgisonTopExprs env exprs = modifyCounter $ runEgisonM $ evalTopExprs env exprs - -runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env) -runEgisonTopExpr env input = modifyCounter $ runEgisonM $ readTopExpr input >>= evalTopExpr env +loadEgisonLibrary env path = evalEgisonTopExpr env (Load path) -runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env) -runEgisonTopExprs env input = modifyCounter $ runEgisonM $ readTopExprs input >>= evalTopExprs 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,6 +1,34 @@ {-# Language TupleSections #-} -module Language.Egison.Core where +{- | +Module : Language.Egison.Core +Copyright : Satoshi Egi +Licence : MIT + +This module provides functions to evaluate various objects. +-} + +module Language.Egison.Core + ( + -- * Egison code evaluation + evalTopExprs + , evalTopExpr + , evalTopExpr' + , evalExpr + , evalExprDeep + , evalRef + , evalRefDeep + , evalWHNF + , applyFunc + -- * Environment + , recursiveBind + -- * Pattern matching + , patternMatch + -- * Utiltiy functions + , fromStringWHNF + , fromStringValue + ) where + import Prelude hiding (mapM) import Control.Arrow @@ -11,6 +39,7 @@ import Data.Sequence (Seq, ViewL(..), ViewR(..), (><)) import qualified Data.Sequence as Sq +import Data.Foldable (toList) import Data.Traversable (mapM) import Data.IORef import Data.List @@ -40,7 +69,7 @@ evalTopExprs env exprs = do (bindings, rest) <- collectDefs exprs [] [] env <- recursiveBind env bindings - forM_ rest $ evalTopExpr env + forM_ rest $ evalTopExpr' env return env where collectDefs (expr:exprs) bindings rest = @@ -56,22 +85,30 @@ collectDefs [] bindings rest = return (bindings, reverse rest) evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env -evalTopExpr env (Define name expr) = recursiveBind env [(name, expr)] -evalTopExpr env (Test expr) = do - val <- evalExpr' env expr - liftIO $ print val - return env -evalTopExpr env (Execute expr) = do +evalTopExpr env topExpr = evalTopExpr'' env topExpr >>= return . snd + +evalTopExpr' :: Env -> EgisonTopExpr -> EgisonM Env +evalTopExpr' env topExpr = do + ret <- evalTopExpr'' env topExpr + liftIO $ putStrLn $ fst ret + return $ snd ret + +evalTopExpr'' :: Env -> EgisonTopExpr -> EgisonM (String, Env) +evalTopExpr'' env (Define name expr) = recursiveBind env [(name, expr)] >>= return . ((,) "") +evalTopExpr'' env (Test expr) = do + val <- evalExprDeep env expr + return ((show val), env) +evalTopExpr'' env (Execute expr) = do io <- evalExpr env expr case io of - Value (IOFunc m) -> m >> return env + Value (IOFunc m) -> m >> return ("", env) _ -> throwError $ TypeMismatch "io" io -evalTopExpr env (Load file) = loadLibraryFile file >>= evalTopExprs env -evalTopExpr env (LoadFile file) = loadFile file >>= evalTopExprs env +evalTopExpr'' env (Load file) = loadLibraryFile file >>= evalTopExprs env >>= return . ((,) "") +evalTopExpr'' env (LoadFile file) = loadFile file >>= evalTopExprs env >>= return . ((,) "") evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c -evalExpr _ (StringExpr s) = return $ Value $ makeStringValue s +evalExpr _ (StringExpr s) = return $ Value $ toEgison s evalExpr _ (BoolExpr b) = return . Value $ Bool b evalExpr _ (RationalExpr x) = return . Value $ Rational x evalExpr _ (IntegerExpr i) = return . Value $ Integer i @@ -85,8 +122,7 @@ evalExpr _ (TupleExpr []) = return . Value $ Tuple [] evalExpr env (TupleExpr [expr]) = evalExpr env expr -evalExpr env (TupleExpr exprs) = - Intermediate . ITuple <$> mapM (newThunk env) exprs +evalExpr env (TupleExpr exprs) = Intermediate . ITuple <$> mapM (newThunk env) exprs evalExpr env (CollectionExpr inners) = if Sq.null inners then @@ -103,8 +139,8 @@ evalExpr env (HashExpr assocs) = do let (keyExprs, exprs) = unzip assocs - keyVals <- mapM (evalExpr' env) keyExprs - keys <- liftError $ mapM makeKey keyVals + keyWhnfs <- mapM (evalExpr env) keyExprs + keys <- mapM makeHashKey keyWhnfs refs <- mapM (newThunk env) exprs case head keys of IntKey _ -> do @@ -115,41 +151,53 @@ let keys' = map (\key -> case key of StrKey s -> s) keys return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs + where + makeHashKey :: WHNFData -> EgisonM EgisonHashKey + makeHashKey (Value val) = + case val of + Integer i -> return (IntKey i) + Collection _ -> do + str <- fromStringWHNF $ Value val + return $ StrKey $ B.pack str + _ -> throwError $ TypeMismatch "integer or string" $ Value val + makeHashKey whnf = do + str <- fromStringWHNF whnf + return $ StrKey $ B.pack str evalExpr env (IndexedExpr expr indices) = do array <- evalExpr env expr - indices <- mapM (evalExpr' env) indices + indices <- mapM (evalExprDeep env) indices refArray array indices where refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData refArray val [] = return val refArray (Value (Array array)) (index:indices) = do - i <- (liftError . liftM fromInteger . fromIntegerValue) (Value index) + i <- (liftM fromInteger . fromEgison) index case IntMap.lookup i array of Just val -> refArray (Value val) indices Nothing -> return $ Value Undefined refArray (Intermediate (IArray array)) (index:indices) = do - i <- (liftError . liftM fromInteger . fromIntegerValue) (Value index) + i <- (liftM fromInteger . fromEgison) index case IntMap.lookup i array of Just ref -> evalRef ref >>= flip refArray indices Nothing -> return $ Value Undefined refArray (Value (IntHash hash)) (index:indices) = do - key <- liftError $ fromIntegerValue $ Value index + key <- fromEgison index case HL.lookup key hash of Just val -> refArray (Value val) indices Nothing -> return $ Value Undefined refArray (Intermediate (IIntHash hash)) (index:indices) = do - key <- liftError $ fromIntegerValue $ Value index + key <- fromEgison index case HL.lookup key hash of Just ref -> evalRef ref >>= flip refArray indices Nothing -> return $ Value Undefined refArray (Value (StrHash hash)) (index:indices) = do - key <- liftError $ fromStringValue $ Value index + key <- fromStringWHNF $ Value index case HL.lookup (B.pack key) hash of Just val -> refArray (Value val) indices Nothing -> return $ Value Undefined refArray (Intermediate (IStrHash hash)) (index:indices) = do - key <- liftError $ fromStringValue $ Value index + key <- fromStringWHNF $ Value index case HL.lookup (B.pack key) hash of Just ref -> evalRef ref >>= flip refArray indices Nothing -> return $ Value Undefined @@ -159,7 +207,7 @@ evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern evalExpr env (IfExpr test expr expr') = do - test <- evalExpr env test >>= liftError . fromBoolValue + test <- evalExpr env test >>= fromWHNF evalExpr env $ if test then expr else expr' evalExpr env (LetExpr bindings expr) = @@ -203,7 +251,7 @@ io <- evalExpr env expr case io of Value (IOFunc m) -> do - val <- m >>= evalDeep + val <- m >>= evalWHNF case val of Tuple [_, val'] -> return $ Value val' _ -> throwError $ TypeMismatch "io" io @@ -258,8 +306,8 @@ evalExpr _ UndefinedExpr = return $ Value Undefined evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr) -evalExpr' :: Env -> EgisonExpr -> EgisonM EgisonValue -evalExpr' env expr = evalExpr env expr >>= evalDeep +evalExprDeep :: Env -> EgisonExpr -> EgisonM EgisonValue +evalExprDeep env expr = evalExpr env expr >>= evalWHNF evalRef :: ObjectRef -> EgisonM WHNFData evalRef ref = do @@ -271,35 +319,36 @@ writeThunk ref val return val -evalRef' :: ObjectRef -> EgisonM EgisonValue -evalRef' ref = do +evalRefDeep :: ObjectRef -> EgisonM EgisonValue +evalRefDeep ref = do obj <- liftIO $ readIORef ref case obj of WHNF (Value val) -> return val WHNF val -> do - val <- evalDeep val + val <- evalWHNF val writeThunk ref $ Value val return val Thunk thunk -> do - val <- thunk >>= evalDeep + val <- thunk >>= evalWHNF writeThunk ref $ Value val return val -evalDeep :: WHNFData -> EgisonM EgisonValue -evalDeep (Value val) = return val -evalDeep (Intermediate (IInductiveData name refs)) = - InductiveData name <$> mapM evalRef' refs -evalDeep (Intermediate (IArray refs)) = do - refs' <- mapM evalRef' $ IntMap.elems refs +evalWHNF :: WHNFData -> EgisonM EgisonValue +evalWHNF (Value val) = return val +evalWHNF (Intermediate (IInductiveData name refs)) = + InductiveData name <$> mapM evalRefDeep refs +evalWHNF (Intermediate (IArray refs)) = do + refs' <- mapM evalRefDeep $ IntMap.elems refs return $ Array $ IntMap.fromList $ zip (enumFromTo 1 (IntMap.size refs)) refs' -evalDeep (Intermediate (IIntHash refs)) = do - refs' <- mapM evalRef' refs +evalWHNF (Intermediate (IIntHash refs)) = do + refs' <- mapM evalRefDeep refs return $ IntHash refs' -evalDeep (Intermediate (IStrHash refs)) = do - refs' <- mapM evalRef' refs +evalWHNF (Intermediate (IStrHash refs)) = do + refs' <- mapM evalRefDeep refs return $ StrHash refs' -evalDeep (Intermediate (ITuple refs)) = Tuple <$> mapM evalRef' refs -evalDeep coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRef' . Sq.fromList) +evalWHNF (Intermediate (ITuple [ref])) = evalRefDeep ref +evalWHNF (Intermediate (ITuple refs)) = Tuple <$> mapM evalRefDeep refs +evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList) applyFunc :: WHNFData -> WHNFData -> EgisonM WHNFData applyFunc (Value (Func env [name] body)) arg = do @@ -311,9 +360,8 @@ then evalExpr (extendEnv env $ makeBindings names refs) body else throwError $ ArgumentsNum (length names) (length refs) applyFunc (Value (PrimitiveFunc func)) arg = do --- fromTuple arg >>= mapM evalRef >>= liftM Value . func - arg' <- fromTuple arg >>= mapM evalRef' - liftM Value . func $ map Value arg' + arg' <- evalWHNF arg + liftM Value . func $ arg' applyFunc (Value (IOFunc m)) arg = do case arg of Value World -> m @@ -322,7 +370,7 @@ generateArray :: Env -> String -> EgisonExpr -> EgisonExpr -> EgisonM WHNFData generateArray env name size expr = do - size' <- evalExpr env size >>= either throwError (return . fromInteger) . fromIntegerValue + size' <- evalExpr env size >>= fromWHNF >>= return . fromInteger elems <- mapM genElem (enumFromTo 1 size') return $ Intermediate $ IArray $ IntMap.fromList elems where @@ -356,32 +404,6 @@ zipWithM_ (\ref expr -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) refs exprs return env' -fromArray :: WHNFData -> EgisonM [ObjectRef] -fromArray (Intermediate (IArray refs)) = return $ IntMap.elems refs -fromArray (Value (Array vals)) = mapM (newEvaluatedThunk . Value) $ IntMap.elems vals -fromArray val = throwError $ TypeMismatch "array" val - -fromTuple :: WHNFData -> EgisonM [ObjectRef] -fromTuple (Intermediate (ITuple refs)) = return refs -fromTuple (Value (Tuple vals)) = mapM (newEvaluatedThunk . Value) vals -fromTuple val = return <$> newEvaluatedThunk val - -fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef) -fromCollection (Value (Collection vals)) = - if Sq.null vals then return MNil - else fromSeq <$> mapM (newEvaluatedThunk . Value) vals -fromCollection coll@(Intermediate (ICollection _)) = - newEvaluatedThunk coll >>= fromCollection' - where - fromCollection' ref = do - isEmpty <- isEmptyCollection ref - if isEmpty - then return MNil - else do - (head, tail) <- fromJust <$> runMaybeT (unconsCollection ref) - return $ MCons head (fromCollection' tail) -fromCollection val = throwError $ TypeMismatch "collection" val - -- -- Pattern Match -- @@ -448,10 +470,10 @@ _ -> throwError $ TypeMismatch "pattern constructor" func LoopPat name (LoopRangeConstant start end) pat pat' -> do - startNum' <- evalExpr' env' start - startNum <- extractInteger startNum' - endNum' <- evalExpr' env' end - endNum <- extractInteger endNum' + startNum' <- evalExpr env' start + startNum <- fromWHNF startNum' + endNum' <- evalExpr env' end + endNum <- fromWHNF endNum' if startNum > endNum then do return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees) @@ -460,8 +482,8 @@ let loops' = LoopContextConstant (name, startNumRef) endNum pat pat' : loops return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees) LoopPat name (LoopRangeVariable start lastNumPat) pat pat' -> do - startNum' <- evalExpr' env' start - startNum <- extractInteger startNum' + startNum' <- evalExpr env' start + startNum <- fromWHNF startNum' startNumRef <- liftIO . newIORef . WHNF $ Value $ Integer startNum lastNumRef <- liftIO . newIORef . WHNF $ Value $ Integer (startNum - 1) return $ fromList [MState env loops bindings (MAtom lastNumPat lastNumRef (Value Something) : MAtom pat' target matcher : trees), @@ -470,8 +492,8 @@ case loops of [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern" LoopContextConstant (name, startNumRef) endNum pat pat' : loops -> do - startNum' <- evalRef' startNumRef - startNum <- extractInteger startNum' + startNum' <- evalRef startNumRef + startNum <- fromWHNF startNum' let nextNum = startNum + 1 if nextNum > endNum then return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees) @@ -480,8 +502,8 @@ let loops' = LoopContextConstant (name, nextNumRef) endNum pat pat' : loops return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees) LoopContextVariable (name, startNumRef) lastNumPat pat pat' : loops -> do - startNum' <- evalRef' startNumRef - startNum <- extractInteger startNum' + startNum' <- evalRef startNumRef + startNum <- fromWHNF startNum' let nextNum = startNum + 1 nextNumRef <- liftIO . newIORef . WHNF $ Value $ Integer nextNum let loops' = LoopContextVariable (name, nextNumRef) lastNumPat pat pat' : loops @@ -500,12 +522,10 @@ return $ fromList $ flip map patterns $ \pattern -> MState env loops bindings (MAtom pattern target matcher : trees) NotPat pattern -> throwError $ strMsg "should not reach here (cut pattern)" - CutPat pattern -> -- TEMPORARY ignoring cut patterns - return $ msingleton (MState env loops bindings ((MAtom pattern target matcher):trees)) PredPat pred -> do func <- evalExpr env' pred arg <- evalRef target - result <- applyFunc func arg >>= liftError . fromBoolValue + result <- applyFunc func arg >>= fromWHNF if result then return $ msingleton $ (MState env loops bindings trees) else return MNil LetPat bindings' pattern -> @@ -528,15 +548,15 @@ _ -> -- Value Something -> -- for tupple patterns case pattern of ValuePat valExpr -> do - val <- evalExpr' env' valExpr - tgtVal <- evalRef' target + val <- evalExprDeep env' valExpr + tgtVal <- evalRefDeep target if val == tgtVal then return $ msingleton $ MState env loops bindings trees else return MNil WildCard -> return $ msingleton $ MState env loops bindings trees PatVar name -> return $ msingleton $ MState env loops ((name, target):bindings) trees IndexedPat (PatVar name) indices -> do - indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices + indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices case lookup name bindings of Just ref -> do obj <- evalRef ref >>= flip updateArray indices >>= newEvaluatedThunk @@ -589,7 +609,7 @@ let env'' = extendEnv env' (bindings' ++ map (\lc -> case lc of (LoopContextConstant binding _ _ _) -> binding (LoopContextVariable binding _ _ _) -> binding) loops') - indices <- mapM (evalExpr env'' >=> liftError . liftM fromInteger . fromIntegerValue) indices + indices <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) indices let pattern' = IndexedPat pattern $ map IntegerExpr indices return $ msingleton $ MState env loops bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name @@ -657,8 +677,8 @@ (++) <$> primitiveDataPatternMatch pattern init <*> primitiveDataPatternMatch pattern' last primitiveDataPatternMatch (PDConstantPat expr) ref = do - target <- lift (evalRef ref) >>= either (const matchFail) return . fromPrimitiveValue - isEqual <- lift $ (==) <$> evalExpr' nullEnv expr <*> pure target + target <- lift (evalRef ref) >>= either (const matchFail) return . fromBuiltinWHNF + isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target if isEqual then return [] else matchFail expandCollection :: WHNFData -> EgisonM (Seq Inner) @@ -726,3 +746,51 @@ lift $ writeThunk ref coll unsnocCollection' coll unsnocCollection' _ = matchFail + +-- +-- Util +-- +fromTuple :: WHNFData -> EgisonM [ObjectRef] +fromTuple (Intermediate (ITuple refs)) = return refs +fromTuple (Value (Tuple vals)) = mapM (newEvaluatedThunk . Value) vals +fromTuple val = return <$> newEvaluatedThunk val + +fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef) +fromCollection (Value (Collection vals)) = + if Sq.null vals then return MNil + else fromSeq <$> mapM (newEvaluatedThunk . Value) vals +fromCollection coll@(Intermediate (ICollection _)) = + newEvaluatedThunk coll >>= fromCollection' + where + fromCollection' ref = do + isEmpty <- isEmptyCollection ref + if isEmpty + then return MNil + else do + (head, tail) <- fromJust <$> runMaybeT (unconsCollection ref) + return $ MCons head (fromCollection' tail) +fromCollection val = throwError $ TypeMismatch "collection" val + +-- +-- String +-- +fromStringWHNF :: WHNFData -> EgisonM String +fromStringWHNF (Value (Collection seq)) = do + let ls = toList seq + mapM (\val -> case val of + Char c -> return c + _ -> throwError $ TypeMismatch "char" (Value val)) + ls +fromStringWHNF (Value (Tuple [val])) = fromStringWHNF (Value val) +fromStringWHNF whnf@(Intermediate (ICollection _)) = evalWHNF whnf >>= fromStringWHNF . Value +fromStringWHNF whnf = throwError $ TypeMismatch "string" whnf + +fromStringValue :: EgisonValue -> EgisonM String +fromStringValue (Collection seq) = do + let ls = toList seq + mapM (\val -> case val of + Char c -> return c + _ -> throwError $ TypeMismatch "char" (Value val)) + ls +fromStringValue (Tuple [val]) = fromStringValue val +fromStringValue val = throwError $ TypeMismatch "string" (Value val) 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,5 +1,21 @@ {-# Language FlexibleInstances, GeneralizedNewtypeDeriving #-} -module Language.Egison.Desugar where + +{- | +Module : Language.Egison.Desugar +Copyright : Satoshi Egi +Licence : MIT + +This module provide desugar functions. +-} + +module Language.Egison.Desugar + ( + DesugarM + , runDesugarM + , desugarTopExpr + , desugar + ) where + import Control.Applicative (Applicative) import Control.Applicative ((<$>), (<*>), (<*), (*>), pure) import qualified Data.Sequence as Sq @@ -193,7 +209,6 @@ collectNames patterns = S.unions $ map collectName patterns collectName :: EgisonPattern -> Set String - collectName (CutPat pattern) = collectName pattern collectName (NotPat pattern) = collectName pattern collectName (AndPat patterns) = collectNames patterns collectName (TuplePat patterns) = collectNames patterns @@ -211,7 +226,6 @@ desugarPattern' :: EgisonPattern -> DesugarM EgisonPattern desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr desugarPattern' (PredPat expr) = PredPat <$> desugar expr -desugarPattern' (CutPat pattern) = CutPat <$> desugarPattern' pattern desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (TuplePat patterns) = TuplePat <$> mapM desugarPattern' patterns 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,15 +1,24 @@ {-# LANGUAGE TupleSections #-} + +{- | +Module : Language.Egison.Parser +Copyright : Satoshi Egi +Licence : MIT + +This module provide Egison parser. +-} + module Language.Egison.Parser - ( readTopExprs + ( + -- * Parse a string + readTopExprs , readTopExpr , readExprs , readExpr - , loadFile + -- * Parse a file , loadLibraryFile - , parseTopExprs - , parseTopExpr - , parseExprs - , parseExpr ) where + , loadFile + ) where import Prelude hiding (mapM) import Control.Monad.Identity hiding (mapM) @@ -36,12 +45,6 @@ import Language.Egison.Types import Language.Egison.Desugar import Paths_egison (getDataFileName) - -doParse :: Parser a -> String -> Either EgisonError a -doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input - where - fromParsecError :: ParseError -> EgisonError - fromParsecError = Parser . show readTopExprs :: String -> EgisonM [EgisonTopExpr] readTopExprs = liftEgisonM . runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs @@ -55,6 +58,11 @@ readExpr :: String -> EgisonM EgisonExpr readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr +-- |Load a libary file +loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] +loadLibraryFile file = liftIO (getDataFileName file) >>= loadFile + +-- |Load a file loadFile :: FilePath -> EgisonM [EgisonTopExpr] loadFile file = do doesExist <- liftIO $ doesFileExist file @@ -70,9 +78,15 @@ shebang ('#':'!':cs) = ';':'#':'!':cs shebang cs = cs +-- +-- Parser +-- -loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] -loadLibraryFile file = liftIO (getDataFileName file) >>= loadFile +doParse :: Parser a -> String -> Either EgisonError a +doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input + where + fromParsecError :: ParseError -> EgisonError + fromParsecError = Parser . show parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] parseTopExprs = doParse $ whiteSpace >> endBy topExpr whiteSpace @@ -89,7 +103,6 @@ -- -- Expressions -- - topExpr :: Parser EgisonTopExpr topExpr = parens (defineExpr <|> testExpr @@ -334,7 +347,6 @@ <|> varPat <|> valuePat <|> predPat - <|> cutPat <|> notPat <|> tuplePat <|> inductivePat @@ -363,9 +375,6 @@ letPat :: Parser EgisonPattern letPat = keywordLet >> LetPat <$> bindings <*> pattern -cutPat :: Parser EgisonPattern -cutPat = reservedOp "!" >> CutPat <$> pattern - notPat :: Parser EgisonPattern notPat = reservedOp "^" >> NotPat <$> pattern @@ -487,7 +496,6 @@ , "&" , "|" , "^" - , "!" , "," , "@" , "..."] 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,13 @@ {-# Language FlexibleContexts #-} + +{- | +Module : Language.Egison.Primitives +Copyright : Satoshi Egi +Licence : MIT + +This module provides primitive functions in Egison. +-} + module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where import Control.Arrow @@ -51,38 +60,37 @@ return $ extendEnv nullEnv bindings {-# INLINE noArg #-} -noArg :: (MonadError EgisonError m) => - m EgisonValue -> - [WHNFData] -> m EgisonValue -noArg f = \vals -> case vals of +noArg :: EgisonM EgisonValue -> + EgisonValue -> EgisonM EgisonValue +noArg f = \args -> case tupleToList args of [] -> f - _ -> throwError $ ArgumentsNum 0 $ length vals + vals -> throwError $ ArgumentsNum 0 $ length vals {-# INLINE oneArg #-} -oneArg :: (MonadError EgisonError m) => - (WHNFData -> m EgisonValue) -> - [WHNFData] -> m EgisonValue -oneArg f = \vals -> case vals of - [val] -> f val - [] -> f $ Value $ Tuple [] - _ -> throwError $ ArgumentsNum 1 $ length vals +oneArg :: (EgisonValue -> EgisonM EgisonValue) -> + EgisonValue -> EgisonM EgisonValue +oneArg f = \args -> case args of + (Tuple [val]) -> f val + _ -> f args {-# INLINE twoArgs #-} -twoArgs :: (MonadError EgisonError m) => - (WHNFData -> WHNFData -> m EgisonValue) -> - [WHNFData] -> m EgisonValue -twoArgs f = \vals -> case vals of +twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> + EgisonValue -> EgisonM EgisonValue +twoArgs f = \args -> case tupleToList args of [val, val'] -> f val val' - _ -> throwError $ ArgumentsNum 2 $ length vals + vals -> throwError $ ArgumentsNum 2 $ length vals {-# INLINE threeArgs #-} -threeArgs :: (MonadError EgisonError m) => - (WHNFData -> WHNFData -> WHNFData -> m EgisonValue) -> - [WHNFData] -> m EgisonValue -threeArgs f = \vals -> case vals of +threeArgs :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> + EgisonValue -> EgisonM EgisonValue +threeArgs f = \args -> case tupleToList args of [val, val', val''] -> f val val' val'' - _ -> throwError $ ArgumentsNum 3 $ length vals + vals -> throwError $ ArgumentsNum 3 $ length vals +tupleToList :: EgisonValue -> [EgisonValue] +tupleToList (Tuple vals) = vals +tupleToList val = [val] + -- -- Constants -- @@ -95,28 +103,29 @@ -- primitives :: [(String, PrimitiveFunc)] -primitives = [ ("+i", integerBinaryOp (+)) - , ("-i", integerBinaryOp (-)) - , ("*i", integerBinaryOp (*)) +primitives = [ ("+", plus) + , ("-", minus) + , ("*", multiply) + , ("/", divide) + , ("/-inverse", divideInverse) + , ("modulo", integerBinaryOp mod) , ("quotient", integerBinaryOp quot) , ("remainder", integerBinaryOp rem) - , ("eq-i?", integerBinaryPred (==)) - , ("lt-i?", integerBinaryPred (<)) - , ("lte-i?", integerBinaryPred (<=)) - , ("gt-i?", integerBinaryPred (>)) - , ("gte-i?", integerBinaryPred (>=)) - , ("+f", floatBinaryOp (+)) - , ("-f", floatBinaryOp (-)) - , ("*f", floatBinaryOp (*)) - , ("/f", floatBinaryOp (/)) - , ("eq-f?", floatBinaryPred (==)) - , ("lt-f?", floatBinaryPred (<)) - , ("lte-f?", floatBinaryPred (<=)) - , ("gt-f?", floatBinaryPred (>)) - , ("gte-f?", floatBinaryPred (>=)) , ("neg", integerUnaryOp negate) , ("abs", integerUnaryOp abs) + + , ("eq?", eq) + , ("lt?", lt) + , ("lte?", lte) + , ("gt?", gt) + , ("gte?", gte) + + , ("round", floatToIntegerOp round) + , ("floor", floatToIntegerOp floor) + , ("ceiling", floatToIntegerOp ceiling) + , ("truncate", floatToIntegerOp truncate) + , ("sqrt", floatUnaryOp sqrt) , ("exp", floatUnaryOp exp) , ("log", floatUnaryOp log) @@ -132,24 +141,15 @@ , ("asinh", floatUnaryOp asinh) , ("acosh", floatUnaryOp acosh) , ("atanh", floatUnaryOp atanh) - , ("round", floatToIntegerOp round) - , ("floor", floatToIntegerOp floor) - , ("ceiling", floatToIntegerOp ceiling) - , ("truncate", floatToIntegerOp truncate) + , ("itof", integerToFloat) , ("rtof", rationalToFloat) - , ("itos", integerToString) + , ("stoi", stringToInteger) - , ("eq?", eq) - , ("lt?", lt) - , ("lte?", lte) - , ("gt?", gt) - , ("gte?", gte) - , ("+", plus) - , ("-", minus) - , ("*", multiply) - , ("/", divide) - , ("/-inverse", divideInverse) + + , ("read", read') + , ("show", show') + , ("assert", assert) , ("assert-equal", assertEqual) @@ -163,194 +163,224 @@ ] integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc -integerUnaryOp op = (liftError .) $ oneArg $ \val -> - Integer . op <$> fromIntegerValue val - +integerUnaryOp op = oneArg $ \val -> do + i <- fromEgison val + return $ Integer $ op i + integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc -integerBinaryOp op = (liftError .) $ twoArgs $ \val val' -> - (Integer .) . op <$> fromIntegerValue val - <*> fromIntegerValue val' +integerBinaryOp op = twoArgs $ \val val' -> do + i <- fromEgison val + i' <- fromEgison val' + return $ Integer $ op i i' integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc -integerBinaryPred pred = (liftError .) $ twoArgs $ \val val' -> - (Bool .) . pred <$> fromIntegerValue val - <*> fromIntegerValue val' +integerBinaryPred pred = twoArgs $ \val val' -> do + i <- fromEgison val + i' <- fromEgison val' + return $ Bool $ pred i i' floatUnaryOp :: (Double -> Double) -> PrimitiveFunc -floatUnaryOp op = (liftError .) $ oneArg $ \val -> - Float . op <$> fromFloatValue val +floatUnaryOp op = oneArg $ \val -> do + f <- fromEgison val + return $ Float $ op f floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc -floatBinaryOp op = (liftError .) $ twoArgs $ \val val' -> - (Float .) . op <$> fromFloatValue val - <*> fromFloatValue val' +floatBinaryOp op = twoArgs $ \val val' -> do + f <- fromEgison val + f' <- fromEgison val' + return $ Float $ op f f' floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc -floatBinaryPred pred = (liftError .) $ twoArgs $ \val val' -> - (Bool .) . pred <$> fromFloatValue val - <*> fromFloatValue val' +floatBinaryPred pred = twoArgs $ \val val' -> do + f <- fromEgison val + f' <- fromEgison val' + return $ Bool $ pred f f' -floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc -floatToIntegerOp op = (liftError .) $ oneArg $ \val -> - Integer . op <$> fromFloatValue val +-- +-- Arith +-- +plus :: PrimitiveFunc +plus = twoArgs $ \val val' -> numberBinaryOp' val val' + where + numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (+) i i' + numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val + numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) + numberBinaryOp' (Rational r) (Rational r') = let y = (+) r r' in + if denominator y == 1 + then return $ Integer $ numerator y + else return $ Rational y + numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) + numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) + numberBinaryOp' (Float f) (Float f') = return $ Float $ (+) f f' + numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) -integerToFloat :: PrimitiveFunc -integerToFloat = (liftError .) $ oneArg $ \val -> - Float . fromInteger <$> fromIntegerValue val +minus :: PrimitiveFunc +minus = twoArgs $ \val val' -> numberBinaryOp' val val' + where + numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (-) i i' + numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val + numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) + numberBinaryOp' (Rational r) (Rational r') = let y = (-) r r' in + if denominator y == 1 + then return $ Integer $ numerator y + else return $ Rational y + numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) + numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) + numberBinaryOp' (Float f) (Float f') = return $ Float $ (-) f f' + numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) -rationalToFloat :: PrimitiveFunc -rationalToFloat = (liftError .) $ oneArg $ \val -> - Float . fromRational <$> fromRationalValue val +multiply :: PrimitiveFunc +multiply = twoArgs $ \val val' -> numberBinaryOp' val val' + where + numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (*) i i' + numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val + numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) + numberBinaryOp' (Rational r) (Rational r') = let y = (*) r r' in + if denominator y == 1 + then return $ Integer $ numerator y + else return $ Rational y + numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) + numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) + numberBinaryOp' (Float f) (Float f') = return $ Float $ (*) f f' + numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) -integerToString :: PrimitiveFunc -integerToString = (liftError .) $ oneArg $ \val -> - makeStringValue . show <$> fromIntegerValue val +divide :: PrimitiveFunc +divide = twoArgs $ \val val' -> numberBinaryOp' val val' + where + numberBinaryOp' (Integer i) (Integer i') = return $ Rational $ (%) i i' + numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val + numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) + numberBinaryOp' (Rational r) (Rational r') = + let m = numerator r' in + let n = denominator r' in + let y = (r * (n % m)) in + if denominator y == 1 + then return $ Integer $ numerator y + else return $ Rational y + numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) + numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) + numberBinaryOp' (Float f) (Float f') = return $ Float $ (/) f f' + numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) -stringToInteger :: PrimitiveFunc -stringToInteger = (liftError .) $ oneArg $ \val -> do - numStr <- fromStringValue val - return $ Integer (read numStr :: Integer) +divideInverse :: PrimitiveFunc +divideInverse = oneArg $ divideInverse' + where + divideInverse' (Rational rat) = do + return $ Tuple [Integer (numerator rat), Integer (denominator rat)] + divideInverse' (Integer x) = do + return $ Tuple [Integer x, Integer 1] + divideInverse' val = throwError $ TypeMismatch "rational" (Value val) +-- +-- Pred +-- eq :: PrimitiveFunc -eq = (liftError .) $ twoArgs $ \val val' -> - (Bool .) . (==) <$> fromPrimitiveValue val - <*> fromPrimitiveValue val' +eq = twoArgs $ \val val' -> + return $ Bool $ val == val' lt :: PrimitiveFunc -lt = (liftError .) $ twoArgs lt' +lt = twoArgs $ \val val' -> numberBinaryPred' val val' where - lt' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i < i' - lt' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i < f - lt' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f < fromInteger i - lt' (Value (Float f)) (Value (Float f')) = return $ Bool $ f < f' - lt' (Value (Integer _)) val = throwError $ TypeMismatch "number" val - lt' (Value (Float _)) val = throwError $ TypeMismatch "number" val - lt' val _ = throwError $ TypeMismatch "number" val - + numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (<) i i' + numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val + numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) + numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<) r r' + numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) + numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) + numberBinaryPred' (Float f) (Float f') = return $ Bool $ (<) f f' + numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + lte :: PrimitiveFunc -lte = (liftError .) $ twoArgs lte' +lte = twoArgs $ \val val' -> numberBinaryPred' val val' where - lte' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i <= i' - lte' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i <= f - lte' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f <= fromInteger i - lte' (Value (Float f)) (Value (Float f')) = return $ Bool $ f <= f' - lte' (Value (Integer _)) val = throwError $ TypeMismatch "number" val - lte' (Value (Float _)) val = throwError $ TypeMismatch "number" val - lte' val _ = throwError $ TypeMismatch "number" val - + numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (<=) i i' + numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val + numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) + numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<=) r r' + numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) + numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) + numberBinaryPred' (Float f) (Float f') = return $ Bool $ (<=) f f' + numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + gt :: PrimitiveFunc -gt = (liftError .) $ twoArgs gt' +gt = twoArgs $ \val val' -> numberBinaryPred' val val' where - gt' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i > i' - gt' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i > f - gt' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f > fromInteger i - gt' (Value (Float f)) (Value (Float f')) = return $ Bool $ f > f' - gt' (Value (Integer _)) val = throwError $ TypeMismatch "number" val - gt' (Value (Float _)) val = throwError $ TypeMismatch "number" val - gt' val _ = throwError $ TypeMismatch "number" val - + numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (>) i i' + numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val + numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) + numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>) r r' + numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) + numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) + numberBinaryPred' (Float f) (Float f') = return $ Bool $ (>) f f' + numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + gte :: PrimitiveFunc -gte = (liftError .) $ twoArgs gte' +gte = twoArgs $ \val val' -> numberBinaryPred' val val' where - gte' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i >= i' - gte' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i >= f - gte' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f >= fromInteger i - gte' (Value (Float f)) (Value (Float f')) = return $ Bool $ f >= f' - gte' (Value (Integer _)) val = throwError $ TypeMismatch "number" val - gte' (Value (Float _)) val = throwError $ TypeMismatch "number" val - gte' val _ = throwError $ TypeMismatch "number" val + numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (>=) i i' + numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val + numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) + numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>=) r r' + numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) + numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) + numberBinaryPred' (Float f) (Float f') = return $ Bool $ (>=) f f' + numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + +-- +-- Transform +-- +integerToFloat :: PrimitiveFunc +integerToFloat = oneArg $ \val -> do + i <- fromEgison val + return $ Float $ fromInteger i -plus :: PrimitiveFunc -plus = (liftError .) $ twoArgs plus' - where - plus' (Value (Integer x)) (Value (Integer x')) = return $ Integer $ (x + x') - plus' (Value (Integer i)) val = plus' (Value (Rational (i % 1))) val - plus' val (Value (Integer i)) = plus' val (Value (Rational (i % 1))) - plus' (Value (Rational x)) (Value (Rational x')) = let y = (x + x') in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - plus' (Value (Float f)) (Value (Float f')) = return $ Float $ f + f' - plus' (Value (Rational i)) (Value (Float f)) = return $ Float $ (fromRational i) + f - plus' (Value (Float f)) (Value (Rational i)) = return $ Float $ f + (fromRational i) - plus' (Value (Rational _)) val = throwError $ TypeMismatch "number" val - plus' (Value (Float _)) val = throwError $ TypeMismatch "number" val - plus' val _ = throwError $ TypeMismatch "number" val +rationalToFloat :: PrimitiveFunc +rationalToFloat = oneArg $ \val -> do + r <- fromEgison val + return $ Float $ fromRational r -minus :: PrimitiveFunc -minus = (liftError .) $ twoArgs minus' - where - minus' (Value (Integer x)) (Value (Integer x')) = return $ Integer $ (x - x') - minus' (Value (Integer i)) val = minus' (Value (Rational (i % 1))) val - minus' val (Value (Integer i)) = minus' val (Value (Rational (i % 1))) - minus' (Value (Rational x)) (Value (Rational x')) = let y = (x - x') in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - minus' (Value (Float f)) (Value (Float f')) = return $ Float $ f - f' - minus' (Value (Rational i)) (Value (Float f)) = return $ Float $ (fromRational i) - f - minus' (Value (Float f)) (Value (Rational i)) = return $ Float $ f - (fromRational i) - minus' (Value (Rational _)) val = throwError $ TypeMismatch "number" val - minus' (Value (Float _)) val = throwError $ TypeMismatch "number" val - minus' val _ = throwError $ TypeMismatch "number" val +floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc +floatToIntegerOp op = oneArg $ \val -> do + f <- fromEgison val + return $ Integer $ op f -multiply :: PrimitiveFunc -multiply = (liftError .) $ twoArgs multiply' - where - multiply' (Value (Integer x)) (Value (Integer x')) = return $ Integer $ (x * x') - multiply' (Value (Integer i)) val = multiply' (Value (Rational (i % 1))) val - multiply' val (Value (Integer i)) = multiply' val (Value (Rational (i % 1))) - multiply' (Value (Rational x)) (Value (Rational x')) = let y = (x * x') in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - multiply' (Value (Float f)) (Value (Float f')) = return $ Float $ f * f' - multiply' (Value (Rational i)) (Value (Float f)) = return $ Float $ (fromRational i) * f - multiply' (Value (Float f)) (Value (Rational i)) = return $ Float $ f * (fromRational i) - multiply' (Value (Rational _)) val = throwError $ TypeMismatch "number" val - multiply' (Value (Float _)) val = throwError $ TypeMismatch "number" val - multiply' val _ = throwError $ TypeMismatch "number" val +read' :: PrimitiveFunc +read'= oneArg $ \val -> fromStringValue val >>= readExpr >>= evalExprDeep nullEnv -divide :: PrimitiveFunc -divide = (liftError .) $ twoArgs divide' - where - divide' (Value (Integer x)) (Value (Integer x')) = return $ Rational $ (x % x') - divide' (Value (Integer i)) val = divide' (Value (Rational (i % 1))) val - divide' val (Value (Integer i)) = divide' val (Value (Rational (i % 1))) - divide' (Value (Rational x)) (Value (Rational x')) = - let m = numerator x' in - let n = denominator x' in - let y = (x * (n % m)) in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - divide' (Value (Rational x)) (Value (Float f)) = return $ Float $ (fromRational x) / f - divide' (Value (Float f)) (Value (Rational x)) = return $ Float $ f / (fromRational x) - divide' (Value (Rational _)) val = throwError $ TypeMismatch "number" val - divide' (Value (Float f)) (Value (Float f')) = return $ Float $ f / f' - divide' (Value (Float _)) val = throwError $ TypeMismatch "number" val - divide' val _ = throwError $ TypeMismatch "number" val +show' :: PrimitiveFunc +show'= oneArg $ \val -> return $ toEgison $ show val -divideInverse :: PrimitiveFunc -divideInverse = (liftError .) $ oneArg $ divideInverse' - where - divideInverse' (Value (Rational rat)) = do - return $ Tuple [Integer (numerator rat), Integer (denominator rat)] - divideInverse' (Value (Integer x)) = do - return $ Tuple [Integer x, Integer 1] - divideInverse' val = throwError $ TypeMismatch "rational" val +stringToInteger :: PrimitiveFunc +stringToInteger = oneArg $ \val -> do + numStr <- fromEgison val + return $ Integer (read numStr :: Integer) + assert :: PrimitiveFunc -assert = (liftError .) $ twoArgs $ \label test -> do - test <- fromBoolValue test +assert = twoArgs $ \label test -> do + test <- fromEgison test if test then return $ Bool True else throwError $ Assertion $ show label assertEqual :: PrimitiveFunc assertEqual = threeArgs $ \label actual expected -> do - actual <- evalDeep actual - expected <- evalDeep expected if actual == expected then return $ Bool True else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++ @@ -361,7 +391,7 @@ dbName <- fromStringValue val qStr <- fromStringValue val' let ret = unsafePerformIO $ query' (T.pack dbName) $ T.pack qStr - return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeStringValue r)) ret + return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeEgisonString r)) ret where query' :: T.Text -> T.Text -> IO [[String]] query' dbName q = do @@ -384,7 +414,7 @@ dbName <- fromStringValue val qStr <- fromStringValue val' let ret = unsafePerformIO $ query' dbName $ BC.pack qStr - return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeStringValue r)) ret + return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeEgisonString r)) ret where query' :: String -> ByteString -> IO [[String]] query' dbName q = do @@ -409,23 +439,21 @@ -- ioPrimitives :: [(String, PrimitiveFunc)] -ioPrimitives = [ ("return", return') +ioPrimitives = [ + ("return", return') , ("open-input-file", makePort ReadMode) , ("open-output-file", makePort WriteMode) , ("close-input-port", closePort) , ("close-output-port", closePort) , ("read-char", readChar) , ("read-line", readLine) - , ("read", readFromStdin) , ("write-char", writeChar) , ("write-string", writeString) - , ("write", writeToStdout) + , ("read-char-from-port", readCharFromPort) , ("read-line-from-port", readLineFromPort) --- , ("read-from-port", readFromPort) , ("write-char-to-port", writeCharToPort) , ("write-string-to-port", writeStringToPort) - , ("write-to-port", writeToPort) , ("eof?", isEOFStdin) , ("flush", flushStdout) @@ -434,8 +462,6 @@ , ("read-file", readFile') , ("rand", randRange) - --- , ("get-lib-dir-name", getLibDirName) ] makeIO :: EgisonM EgisonValue -> EgisonValue @@ -445,77 +471,85 @@ makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []]) return' :: PrimitiveFunc -return' = oneArg $ return . makeIO . evalDeep +return' = oneArg $ \val -> return $ makeIO $ return val makePort :: IOMode -> PrimitiveFunc -makePort mode = (liftError .) $ oneArg $ \val -> do - filename <- fromStringValue val - return . makeIO . liftIO $ Port <$> openFile filename mode +makePort mode = oneArg $ \val -> do + filename <- fromEgison val + port <- liftIO $ openFile filename mode + return $ makeIO $ return (Port port) closePort :: PrimitiveFunc -closePort = (liftError .) $ oneArg $ \val -> - makeIO' . liftIO . hClose <$> fromPortValue val +closePort = oneArg $ \val -> do + port <- fromEgison val + return $ makeIO' $ liftIO $ hClose port writeChar :: PrimitiveFunc -writeChar = (liftError .) $ oneArg $ \val -> - makeIO' . liftIO . putChar <$> fromCharValue val - -writeString :: PrimitiveFunc -writeString = (liftError .) $ oneArg $ \val -> - makeIO' . liftIO . putStr <$> fromStringValue val - -writeToStdout :: PrimitiveFunc -writeToStdout = oneArg $ \val -> - makeIO' . liftIO . putStr . show <$> evalDeep val - -readChar :: PrimitiveFunc -readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar +writeChar = oneArg $ \val -> do + c <- fromEgison val + return $ makeIO' $ liftIO $ putChar c -readLine :: PrimitiveFunc -readLine = noArg $ return $ makeIO $ liftIO $ liftM makeStringValue getLine +writeCharToPort :: PrimitiveFunc +writeCharToPort = twoArgs $ \val val' -> do + port <- fromEgison val + c <- fromEgison val' + return $ makeIO' $ liftIO $ hPutChar port c -readFromStdin :: PrimitiveFunc -readFromStdin = noArg $ return $ makeIO $ (liftIO getLine) >>= readExpr >>= evalExpr' nullEnv +writeString :: PrimitiveFunc +writeString = oneArg $ \val -> do + s <- fromEgison val + return $ makeIO' $ liftIO $ putStr s + +writeStringToPort :: PrimitiveFunc +writeStringToPort = twoArgs $ \val val' -> do + port <- fromEgison val + s <- fromEgison val' + return $ makeIO' $ liftIO $ hPutStr port s flushStdout :: PrimitiveFunc flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout -isEOFStdin :: PrimitiveFunc -isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF - -writeCharToPort :: PrimitiveFunc -writeCharToPort = (liftError .) $ twoArgs $ \val val' -> - ((makeIO' . liftIO) .) . hPutChar <$> fromPortValue val <*> fromCharValue val' - -writeStringToPort :: PrimitiveFunc -writeStringToPort = (liftError .) $ twoArgs $ \val val' -> - ((makeIO' . liftIO) .) . hPutStr <$> fromPortValue val <*> fromStringValue val' +flushPort :: PrimitiveFunc +flushPort = oneArg $ \val -> do + port <- fromEgison val + return $ makeIO' $ liftIO $ hFlush port -writeToPort :: PrimitiveFunc -writeToPort = twoArgs $ \val val' -> do - ((makeIO' . liftIO) .) . hPutStr <$> liftError (fromPortValue val) - <*> (show <$> evalDeep val') +readChar :: PrimitiveFunc +readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar readCharFromPort :: PrimitiveFunc -readCharFromPort = (liftError .) $ oneArg $ \val -> - makeIO . liftIO . liftM Char . hGetChar <$> fromPortValue val +readCharFromPort = oneArg $ \val -> do + port <- fromEgison val + c <- liftIO $ hGetChar port + return $ makeIO $ return (Char c) +readLine :: PrimitiveFunc +readLine = noArg $ return $ makeIO $ liftIO $ liftM toEgison getLine + readLineFromPort :: PrimitiveFunc -readLineFromPort = (liftError .) $ oneArg $ \val -> - makeIO . liftIO . liftM makeStringValue . hGetLine <$> fromPortValue val +readLineFromPort = oneArg $ \val -> do + port <- fromEgison val + s <- liftIO $ hGetLine port + return $ makeIO $ return $ toEgison s -flushPort :: PrimitiveFunc -flushPort = (liftError .) $ oneArg $ \val -> - makeIO' . liftIO . hFlush <$> fromPortValue val +readFile' :: PrimitiveFunc +readFile' = oneArg $ \val -> do + filename <- fromEgison val + s <- liftIO $ readFile filename + return $ makeIO $ return $ toEgison s + +isEOFStdin :: PrimitiveFunc +isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF isEOFPort :: PrimitiveFunc -isEOFPort = (liftError .) $ oneArg $ \val -> - makeIO . liftIO . liftM Bool . hIsEOF <$> fromPortValue val +isEOFPort = oneArg $ \val -> do + port <- fromEgison val + b <- liftIO $ hIsEOF port + return $ makeIO $ return (Bool b) -readFile' :: PrimitiveFunc -readFile' = (liftError .) $ oneArg $ \val -> - makeIO . liftIO . liftM makeStringValue . readFile <$> fromStringValue val - randRange :: PrimitiveFunc -randRange = (liftError .) $ twoArgs $ \val val' -> - return . makeIO . liftIO . liftM Integer . getStdRandom . randomR =<< liftM2 (,) (fromIntegerValue val) (fromIntegerValue val') +randRange = twoArgs $ \val val' -> do + i <- fromEgison val + i' <- fromEgison val' + n <- liftIO $ getStdRandom $ randomR (i, i') + return $ makeIO $ return (Integer n) 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,7 +1,81 @@ {-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable #-} -module Language.Egison.Types where + MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable, + TypeFamilies #-} +{- | +Module : Language.Egison.Types +Copyright : Satoshi Egi +Licence : MIT +This module contains type definitions of Egison Data. +-} + +module Language.Egison.Types + ( + -- * Egison expressions + EgisonTopExpr (..) + , EgisonExpr (..) + , EgisonPattern (..) + , InnerExpr (..) + , BindingExpr (..) + , MatchClause (..) + , MatcherInfo (..) + , LoopRange (..) + , PrimitivePatPattern (..) + , PrimitiveDataPattern (..) + -- * Egison values + , EgisonValue (..) + , Matcher (..) + , PrimitiveFunc (..) + , EgisonHashKey (..) -- TODO ? + , Egison (..) + , fromMatcherValue + -- * Internal data + , Object (..) + , ObjectRef (..) + , WHNFData (..) + , Intermediate (..) + , Inner (..) + , EgisonWHNF (..) + , fromBuiltinWHNF -- TODO ? + -- * Environment + , Env (..) + , Var (..) + , Binding (..) + , nullEnv + , extendEnv + , refVar + -- * Pattern matching + , PMMode (..) + , MatchingState (..) + , MatchingTree (..) + , PatternBinding (..) + , LoopContext (..) + -- * Errors + , EgisonError (..) + , liftError + -- * Monads + , EgisonM (..) + , runEgisonM + , liftEgisonM + , fromEgisonM + , FreshT (..) + , Fresh (..) + , MonadFresh (..) + , runFreshT + , MatchM (..) + , matchFail + , MList (..) + , fromList + , fromSeq + , fromMList + , msingleton + , mfoldr + , mappend + , mconcat + , mmap + , mfor + ) where + import Prelude hiding (foldr) import Control.Exception @@ -16,9 +90,9 @@ import Control.Monad.Trans.Maybe import Data.Monoid (Monoid) -import Data.Foldable (foldr, toList) import qualified Data.Sequence as Sq import Data.Sequence (Seq) +import Data.Foldable (foldr, toList) import Data.IORef import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -33,6 +107,8 @@ import qualified Data.IntMap as IntMap import Data.Ratio +import System.IO.Unsafe (unsafePerformIO) + -- -- Expressions -- @@ -89,6 +165,11 @@ | UndefinedExpr deriving (Show) +data InnerExpr = + ElementExpr EgisonExpr + | SubCollectionExpr EgisonExpr + deriving (Show) + type BindingExpr = ([String], EgisonExpr) type MatchClause = (EgisonPattern, EgisonExpr) type MatcherInfo = [(PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])] @@ -101,7 +182,6 @@ | PredPat EgisonExpr | IndexedPat EgisonPattern [EgisonExpr] | LetPat [BindingExpr] EgisonPattern - | CutPat EgisonPattern | NotPat EgisonPattern | AndPat [EgisonPattern] | OrPat [EgisonPattern] @@ -134,11 +214,6 @@ | PDConstantPat EgisonExpr deriving (Show) -data InnerExpr = - ElementExpr EgisonExpr - | SubCollectionExpr EgisonExpr - deriving (Show) - -- -- Values -- @@ -167,8 +242,12 @@ | EOF type Matcher = (Env, MatcherInfo) -type PrimitiveFunc = [WHNFData] -> EgisonM EgisonValue +type PrimitiveFunc = EgisonValue -> EgisonM EgisonValue +data EgisonHashKey = + IntKey Integer + | StrKey ByteString + instance Show EgisonValue where show (Char c) = "'" ++ [c] ++ "'" show (Bool True) = "#t" @@ -214,6 +293,100 @@ _ == _ = False -- +-- Egison data and Haskell data +-- +class Egison a where + toEgison :: a -> EgisonValue + fromEgison :: EgisonValue -> EgisonM a + +instance Egison Char where + toEgison c = Char c + fromEgison = liftError . fromCharValue + +instance Egison Bool where + toEgison b = Bool b + fromEgison = liftError . fromBoolValue + +instance Egison Integer where + toEgison i = Integer i + fromEgison = liftError . fromIntegerValue + +instance Egison Rational where + toEgison r = Rational r + fromEgison = liftError . fromRationalValue + +instance Egison Double where + toEgison f = Float f + fromEgison = liftError . fromFloatValue + +instance Egison Handle where + toEgison h = Port h + fromEgison = liftError . fromPortValue + +instance (Egison a) => Egison [a] where + toEgison xs = Collection $ Sq.fromList (map toEgison xs) + fromEgison (Collection seq) = mapM fromEgison (toList seq) + fromEgison val = liftError $ throwError $ TypeMismatch "collection" (Value val) + +instance Egison () where + toEgison () = Tuple [] + fromEgison (Tuple []) = return () + fromEgison val = liftError $ throwError $ TypeMismatch "zero element tuple" (Value val) + +instance (Egison a, Egison b) => Egison (a, b) where + toEgison (x, y) = Tuple [toEgison x, toEgison y] + fromEgison (Tuple (x:y:[])) = (liftM2 (,)) (fromEgison x) (fromEgison y) + fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val) + +instance (Egison a, Egison b, Egison c) => Egison (a, b, c) where + toEgison (x, y, z) = Tuple [toEgison x, toEgison y, toEgison z] + fromEgison (Tuple (x:y:z:[])) = do + x' <- fromEgison x + y' <- fromEgison y + z' <- fromEgison z + return (x', y', z') + fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val) + +instance (Egison a, Egison b, Egison c, Egison d) => Egison (a, b, c, d) where + toEgison (x, y, z, w) = Tuple [toEgison x, toEgison y, toEgison z, toEgison w] + fromEgison (Tuple (x:y:z:w:[])) = do + x' <- fromEgison x + y' <- fromEgison y + z' <- fromEgison z + w' <- fromEgison w + return (x', y', z', w') + fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val) + +fromCharValue :: EgisonValue -> Either EgisonError Char +fromCharValue (Char c) = return c +fromCharValue val = throwError $ TypeMismatch "char" (Value val) + +fromBoolValue :: EgisonValue -> Either EgisonError Bool +fromBoolValue (Bool b) = return b +fromBoolValue val = throwError $ TypeMismatch "bool" (Value val) + +fromIntegerValue :: EgisonValue -> Either EgisonError Integer +fromIntegerValue (Integer i) = return i +fromIntegerValue val = throwError $ TypeMismatch "integer" (Value val) + +fromRationalValue :: EgisonValue -> Either EgisonError Rational +fromRationalValue (Rational x) = return x +fromRationalValue val = throwError $ TypeMismatch "rational" (Value val) + +fromFloatValue :: EgisonValue -> Either EgisonError Double +fromFloatValue (Float f) = return f +fromFloatValue val = throwError $ TypeMismatch "float" (Value val) + +fromPortValue :: EgisonValue -> Either EgisonError Handle +fromPortValue (Port handle) = return handle +fromPortValue val = throwError $ TypeMismatch "port" (Value val) + +-- TODO : write instance declaration for Matcher +fromMatcherValue :: EgisonValue -> Either EgisonError Matcher +fromMatcherValue (Matcher matcher) = return matcher +fromMatcherValue val = throwError $ TypeMismatch "matcher" (Value val) + +-- -- Internal Data -- @@ -248,76 +421,77 @@ show (Intermediate (IIntHash _)) = "{|...|}" show (Intermediate (IStrHash _)) = "{|...|}" -data EgisonHashKey = - IntKey Integer - | StrKey ByteString - -makeKey :: EgisonValue -> Either EgisonError EgisonHashKey -makeKey val = - case val of - Integer i -> return (IntKey i) - Collection _ -> do - str <- fromStringValue $ Value val - return $ StrKey $ B.pack str - _ -> throwError $ TypeMismatch "integer or string" $ Value val - -fromCharValue :: WHNFData -> Either EgisonError Char -fromCharValue (Value (Char c)) = return c -fromCharValue val = throwError $ TypeMismatch "char" val - -fromStringValue :: WHNFData -> Either EgisonError String -fromStringValue (Value (Collection seq)) = do - let ls = toList seq - mapM (\val -> case val of - Char c -> return c - _ -> throwError $ TypeMismatch "char" (Value val)) - ls -fromStringValue val = throwError $ TypeMismatch "string" val - -makeStringValue :: String -> EgisonValue -makeStringValue str = Collection $ Sq.fromList $ map Char str - -fromBoolValue :: WHNFData -> Either EgisonError Bool -fromBoolValue (Value (Bool b)) = return b -fromBoolValue val = throwError $ TypeMismatch "bool" val +-- +-- Extract data from WHNF +-- +class EgisonWHNF a where + fromWHNF :: WHNFData -> EgisonM a + +instance EgisonWHNF Char where + fromWHNF = liftError . fromCharWHNF + +instance EgisonWHNF Bool where + fromWHNF = liftError . fromBoolWHNF + +instance EgisonWHNF Integer where + fromWHNF = liftError . fromIntegerWHNF + +instance EgisonWHNF Rational where + fromWHNF = liftError . fromRationalWHNF + +instance EgisonWHNF Double where + fromWHNF = liftError . fromFloatWHNF + +instance EgisonWHNF Handle where + fromWHNF = liftError . fromPortWHNF + +instance EgisonWHNF Matcher where + fromWHNF = liftError . fromMatcherWHNF + +fromCharWHNF :: WHNFData -> Either EgisonError Char +fromCharWHNF (Value (Char c)) = return c +fromCharWHNF whnf = throwError $ TypeMismatch "char" whnf -fromRationalValue :: WHNFData -> Either EgisonError Rational -fromRationalValue (Value (Rational x)) = return x -fromRationalValue val = throwError $ TypeMismatch "rational" val +fromBoolWHNF :: WHNFData -> Either EgisonError Bool +fromBoolWHNF (Value (Bool b)) = return b +fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf -fromIntegerValue :: WHNFData -> Either EgisonError Integer -fromIntegerValue (Value (Integer i)) = return i -fromIntegerValue val = throwError $ TypeMismatch "integer" val +fromIntegerWHNF :: WHNFData -> Either EgisonError Integer +fromIntegerWHNF (Value (Integer i)) = return i +fromIntegerWHNF whnf = throwError $ TypeMismatch "integer" whnf -fromFloatValue :: WHNFData -> Either EgisonError Double -fromFloatValue (Value (Float f)) = return f -fromFloatValue val = throwError $ TypeMismatch "float" val +fromRationalWHNF :: WHNFData -> Either EgisonError Rational +fromRationalWHNF (Value (Rational x)) = return x +fromRationalWHNF whnf = throwError $ TypeMismatch "rational" whnf -fromPortValue :: WHNFData -> Either EgisonError Handle -fromPortValue (Value (Port handle)) = return handle -fromPortValue val = throwError $ TypeMismatch "port" val +fromFloatWHNF :: WHNFData -> Either EgisonError Double +fromFloatWHNF (Value (Float f)) = return f +fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf -fromMatcherValue :: WHNFData -> Either EgisonError Matcher -fromMatcherValue (Value (Matcher matcher)) = return matcher -fromMatcherValue val = throwError $ TypeMismatch "matcher" val +fromPortWHNF :: WHNFData -> Either EgisonError Handle +fromPortWHNF (Value (Port handle)) = return handle +fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf -fromPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue -fromPrimitiveValue (Value val@(Char _)) = return val -fromPrimitiveValue (Value val@(Bool _)) = return val -fromPrimitiveValue (Value val@(Integer _)) = return val -fromPrimitiveValue (Value val@(Float _)) = return val -fromPrimitiveValue val = throwError $ TypeMismatch "primitive value" val +fromMatcherWHNF :: WHNFData -> Either EgisonError Matcher +fromMatcherWHNF (Value (Matcher matcher)) = return matcher +fromMatcherWHNF whnf = throwError $ TypeMismatch "matcher" whnf -extractInteger :: EgisonValue -> EgisonM Integer -extractInteger (Integer i) = return i -extractInteger val = throwError $ TypeMismatch "integer" (Value val) +-- +-- +-- +fromBuiltinWHNF :: WHNFData -> Either EgisonError EgisonValue +fromBuiltinWHNF (Value val@(Char _)) = return val +fromBuiltinWHNF (Value val@(Bool _)) = return val +fromBuiltinWHNF (Value val@(Integer _)) = return val +fromBuiltinWHNF (Value val@(Float _)) = return val +fromBuiltinWHNF whnf = throwError $ TypeMismatch "primitive value" whnf -- -- Environment -- -type Var = String type Env = [HashMap Var ObjectRef] +type Var = String type Binding = (Var, ObjectRef) nullEnv :: Env @@ -391,6 +565,39 @@ -- Monads -- +newtype EgisonM a = EgisonM { + unEgisonM :: ErrorT EgisonError (FreshT IO) a + } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh) + +runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a) +runEgisonM = runErrorT . unEgisonM + +liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a +liftEgisonM m = EgisonM $ ErrorT $ FreshT $ do + s <- get + (a, s') <- return $ runFresh s m + put s' + return $ either throwError return $ a + +fromEgisonM :: EgisonM a -> IO (Either EgisonError a) +fromEgisonM = modifyCounter . runEgisonM + +counter :: IORef Int +counter = unsafePerformIO (newIORef 0) + +readCounter :: IO Int +readCounter = readIORef counter + +updateCounter :: Int -> IO () +updateCounter = writeIORef counter + +modifyCounter :: FreshT IO a -> IO a +modifyCounter m = do + seed <- readCounter + (result, seed) <- runFreshT seed m + updateCounter seed + return result + newtype FreshT m a = FreshT { unFreshT :: StateT Int m a } deriving (Functor, Applicative, Monad, MonadState Int, MonadTrans) @@ -432,20 +639,7 @@ runFresh :: Int -> Fresh a -> (a, Int) runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m -newtype EgisonM a = EgisonM { - unEgisonM :: ErrorT EgisonError (FreshT IO) a - } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh) -runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a) -runEgisonM = runErrorT . unEgisonM - -liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a -liftEgisonM m = EgisonM $ ErrorT $ FreshT $ do - s <- get - (a, s') <- return $ runFresh s m - put s' - return $ either throwError return $ a - type MatchM = MaybeT EgisonM matchFail :: MatchM a diff --git a/hs-src/Language/Egison/Util.hs b/hs-src/Language/Egison/Util.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Util.hs @@ -0,0 +1,86 @@ + +{- | +Module : Language.Egison.Util +Copyright : Satoshi Egi +Licence : MIT + +This module provides utility functions. +-} + +module Language.Egison.Util (completeEgison) where + +import Data.List +import System.Console.Haskeline hiding (handle, catch, throwTo) + +-- |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 + +completeAfterOpenParen :: Monad m => String -> m [Completion] +completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenParen + +completeAfterOpenCons :: Monad m => String -> m [Completion] +completeAfterOpenCons str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenCons + +completeNothing :: Monad m => String -> m [Completion] +completeNothing _ = return [] + +completeEgisonKeyword :: Monad m => String -> m [Completion] +completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords + +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", "empty?", "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", "qsort", "intersperse", "intercalate", "split", "split/m"] +egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"] +egisonKeywordsInNeutral = ["something"] + ++ ["bool", "string", "integer", "nats", "primes"] +egisonKeywords = 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)]) + +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 (c:str) = c:(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 + +closeParen' :: Integer -> String -> Maybe String +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 +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 + 1) str +closeParen' n ('}':str) = closeParen' (n + 1) str +closeParen' n (_:str) = closeParen' n str diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -55,8 +55,8 @@ (define $between (lambda [$s $e] - (if (gt-i? (+ s 10) e) - (if (gt-i? s e) + (if (gt? (+ s 10) e) + (if (gt? s e) {} {s @(between (+ s 1) e)}) {s (+ s 1) (+ s 2) (+ s 3) (+ s 4) (+ s 5) (+ s 6) (+ s 7) (+ s 8) (+ s 9) (+ s 10) @(between (+ s 11) e)}) diff --git a/sample/bipartite-graph.egi b/sample/bipartite-graph.egi new file mode 100644 --- /dev/null +++ b/sample/bipartite-graph.egi @@ -0,0 +1,87 @@ +;;; +;;; +;;; Bipartite Graph demonstartion +;;; +;;; + +;; +;; Matcher definitions +;; +(define $bipartite-graph + (lambda [$a $b] + (multiset (edge a b)))) + +(define $edge + (lambda [$a $b] + (algebraic-data-matcher + {}))) + +;; +;; Demonstration code +;; +(define $bipartite-graph-data + { + + + + + + + + + + + + + + + + + + + }) + +(test (match-all bipartite-graph-data (bipartite-graph integer string) + [ _> str])) + +(test (unique/m integer + (match-all bipartite-graph-data (bipartite-graph integer string) + [ + + ^ _>>> + n]))) + +(test (unique/m integer + (match-all bipartite-graph-data (bipartite-graph integer string) + [ + + ^ _>>> + n]))) + +(test (unique/m integer + (match-all bipartite-graph-data (bipartite-graph integer string) + [ _> + n]))) + +(test (unique/m integer + (match-all bipartite-graph-data (bipartite-graph integer string) + [ + + _>> + n]))) + +;; I found bug on nested not-patterns +;(test (unique/m integer +; (match-all bipartite-graph-data (bipartite-graph integer string) +; [(& +; +; _>>> +; ^ +; ^ _>>) +; n]))) + +(test (unique/m integer + (match-all bipartite-graph-data (bipartite-graph integer string) + [ + ^ _>> + n2]))) diff --git a/sample/graph.egi b/sample/graph.egi new file mode 100644 --- /dev/null +++ b/sample/graph.egi @@ -0,0 +1,86 @@ +;;; +;;; +;;; Graph demonstartion +;;; +;;; + +;; +;; Matcher definitions +;; +(define $graph + (lambda [$a] + (set (edge a)))) + +(define $edge + (lambda [$a] + (algebraic-data-matcher + {}))) + +;; +;; Sample data +;; +(define $graph-data1 + { + + + + + + + }) + +(define $graph-data2 + { + + + + + + + + + + + + }) + +;; +;; Demonstration code +;; +;; find all nodes who have an edege from 's' but not have an edge to 's' +(test (let {[$s 1]} + (match-all graph-data1 (graph integer) + [ + ^ + _>> + x]))) + +;; find all nodes in two path from 's' +(test (let {[$s 1]} + (match-all graph-data1 (graph integer) + [ + + _>> + x]))) + +;; enumerate first 5 paths from 's' to 'e' +(test (take 5 (let {[$s 1] [$e 2]} + (match-all graph-data2 (graph integer) + [ + (loop $i [4 $n] + ...> + _>)> + x])))) + +;; find all cliques whose size is 'n' +(test (let {[$n 3]} + (match-all graph-data2 (graph integer) + [ + (loop $i [3 ,n] + + (loop $j [2 ,(- i 1)] + ...> + ...) + _> + _)> + x]))) diff --git a/sample/io/argv.egi b/sample/io/argv.egi new file mode 100644 --- /dev/null +++ b/sample/io/argv.egi @@ -0,0 +1,18 @@ +(define $write-each + (lambda [$xs] + (match xs (list something) + {[ (do {} [])] + [ + (do {[(write-string x)] + [(write-string "\n")] + [(write-each rs)] + } + [])]}))) + +(define $main + (lambda [$argv] + (do {[(write-string "argv: ")] + [(write argv)] + [(write-string "\n")] + [(write-each argv)]} + []))) diff --git a/sample/io/cat.egi b/sample/io/cat.egi new file mode 100644 --- /dev/null +++ b/sample/io/cat.egi @@ -0,0 +1,44 @@ +(define $main + (lambda [$argv] + (match argv (list string) + {[ (letrec {[$iter + (do {[$eof (eof?)] + [(unless eof + (do {[$line (read-line)] + [(write-string line)] + [(write-char '\n')] + [iter]} + []))]} + [])]} + iter)] + [_ (cat-files argv)]}))) + +(define $cat-files + (match-lambda (list string) + {[ nop] + [ + (do {[$port (open-input-file file)] + [(letrec {[$iter + (do {[$eof (eof-port? port)] + [(unless eof + (do {[$line (read-line-from-port port)] + [(write-string line)] + [(write-char '\n')] + [iter]} + []))]} + [])]} + iter)] + [(close-input-port port)] + [(cat-files files)]} + [])]})) + +(define $nop + (return [])) + +(define $when + (lambda [$cond $action] + (if cond action nop))) + +(define $unless + (lambda [$cond $action] + (when (not cond) action))) diff --git a/sample/io/cat2.egi b/sample/io/cat2.egi new file mode 100644 --- /dev/null +++ b/sample/io/cat2.egi @@ -0,0 +1,5 @@ +(define $main + (lambda [$argv] + (do {[$content (read-file (car argv))] + [(write-string content)]} + []))) diff --git a/sample/io/dice.egi b/sample/io/dice.egi new file mode 100644 --- /dev/null +++ b/sample/io/dice.egi @@ -0,0 +1,6 @@ +(define $main + (lambda [$argv] + (do {[$v (rand 1 6)] + [(write v)] + [(write-char '\n')]} + []))) diff --git a/sample/io/hello.egi b/sample/io/hello.egi new file mode 100644 --- /dev/null +++ b/sample/io/hello.egi @@ -0,0 +1,3 @@ +(define $main + (lambda [$args] + (print "Hello, world!"))) diff --git a/sample/io/interactive.egi b/sample/io/interactive.egi new file mode 100644 --- /dev/null +++ b/sample/io/interactive.egi @@ -0,0 +1,17 @@ +(define $repl + (lambda [] + (do {[(write-string "input: ")] + [(flush)] + [$input (read)] + [(write input)] + [(print "")] + [(write (take 3 input))] + [(print "")] + [(repl)] + } + []))) + +(define $main + (lambda [$argv] + (do {[(repl)]} + []))) diff --git a/sample/io/print-primes.egi b/sample/io/print-primes.egi new file mode 100644 --- /dev/null +++ b/sample/io/print-primes.egi @@ -0,0 +1,4 @@ +(define $main + (lambda [$argv] + (do {[(each print (map itos primes))]} + []))) diff --git a/sample/mahjong.egi b/sample/mahjong.egi new file mode 100644 --- /dev/null +++ b/sample/mahjong.egi @@ -0,0 +1,73 @@ +;;; +;;; +;;; Mah-jong example +;;; +;;; + +;; +;; Matcher definitions +;; +(define $suit + (algebraic-data-matcher + { })) + +(define $honor + (algebraic-data-matcher + { })) + +(define $hai + (algebraic-data-matcher + { })) + +;; +;; Pattern modularizations +;; +(define $twin + (pattern-function [$pat1 $pat2] + >)) + +(define $shuntsu + (pattern-function [$pat1 $pat2] + pat1) + + + pat2>>>)) + +(define $kohtsu + (pattern-function [$pat1 $pat2] + >>)) + +;; +;; A function that determins whether the hand is finished or not. +;; +(define $agari? + (match-lambda (multiset hai) + {[(twin $th_1 + (| (shuntsu $sh_1 (| (shuntsu $sh_2 (| (shuntsu $sh_3 (| (shuntsu $sh_4 ) + (kohtsu $kh_1 ))) + (kohtsu $kh_1 (kohtsu $kh_2 )))) + (kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 ))))) + (kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 (kohtsu $kh_4 ))))) + (twin $th_2 (twin $th_3 (twin $th_4 (twin $th_5 (twin $th_6 (twin $th_7 ))))))) + #t] + [_ #f]})) + +;; +;; Demonstration code +;; +(test (agari? {> > + 3> 4> 5> + 6> 7> 8> + 2> 3> 4> + 6> 6> 6>})) + +(test (agari? {> > + 1> 3> 4> + 6> 7> 8> + 3> 4> 5> + 6> 6> 6>})) diff --git a/sample/n-queen.egi b/sample/n-queen.egi new file mode 100644 --- /dev/null +++ b/sample/n-queen.egi @@ -0,0 +1,58 @@ +(define $eight-queen + (match-all {1 2 3 4 5 6 7 8} (multiset integer) + [>>>>>>>> + a])) + +(test eight-queen) + +(define $n-queen + (lambda [$n] + (match-all (between 1 n) (multiset integer) + [ + )> + a]))) + +(test (n-queen 4)) diff --git a/sample/poker-hands.egi b/sample/poker-hands.egi new file mode 100644 --- /dev/null +++ b/sample/poker-hands.egi @@ -0,0 +1,114 @@ +;;; +;;; +;;; Poker-hands demonstration +;;; +;;; + +;; +;; Matcher definitions +;; +(define $suit + (algebraic-data-matcher + { })) + +(define $card + (algebraic-data-matcher + {})) + +;; +;; A function that determins poker-hands +;; +(define $poker-hands + (lambda [$cs] + (match cs (multiset card) + {[ + + + + + >>>>> + ] + [ + + + + >>>>> + ] + [ + + + + + >>>>> + ] + [ + + + + + >>>>> + ] + [ + + + + + >>>>> + ] + [ + + + >>>>> + ] + [ + + + + >>>>> + ] + [ + + >>>>> + ] + [>>>>> + ]}))) + +;; +;; Demonstration code +;; +(test (poker-hands { 12> + 10> + 13> + 1> + 11>})) + +(test (poker-hands { 1> + 2> + 1> + 1> + 2>})) + +(test (poker-hands { 4> + 2> + 5> + 1> + 3>})) + +(test (poker-hands { 4> + 10> + 5> + 1> + 3>})) + diff --git a/sample/sequence.egi b/sample/sequence.egi new file mode 100644 --- /dev/null +++ b/sample/sequence.egi @@ -0,0 +1,32 @@ +;;; +;;; +;;; Pattern-matching against sequence of natural numbers +;;; +;;; + +; first 100 natural numbers +(test (take 100 nats)) + +; inifinite list of two-combinations of numbers +(define $pairs (match-all nats (list integer) + [ >)> + [m n]])) + +; test 'pairs' +(test (take 100 pairs)) + +; infinite list of pythagoras numbers +(define $pyths (map (lambda [$m $n] (+ (power m 2) (power n 2))) pairs)) + +; test 'pyths' +(test (take 100 pyths)) + +; function that enumerates all common elements between two lists +(define $commons + (lambda [$xs $ys] + (match-all [xs ys] [(multiset integer) (multiset integer)] + [[ ] + c]))) + +; test 'commons' +(test (commons (take 100 primes) (take 300 pyths))) diff --git a/sample/social-graph.egi b/sample/social-graph.egi new file mode 100644 --- /dev/null +++ b/sample/social-graph.egi @@ -0,0 +1,81 @@ +;;; +;;; +;;; Social-graph Demonstration +;;; +;;; + +;; +;; Matcher definition +;; +(define $user + (matcher + {[,$u [] + {[$tgt (match [u tgt] [user user] + {[[ ] {[]}] + [_ {}]})]}] + [ [integer] + {[ {id}]}] + [ [string] + {[ {name}]}] + [ [string] + {[ {txt}]}] + [$ [something] + {[$tgt {tgt}]}] + })) + +(define $user-table (multiset user)) + +(define $follow + (matcher + {[,$f [] + {[$tgt (match [f tgt] [follow follow] + {[[(& ) (& )] {[]}] + [_ {}]})]}] + [ [integer] + {[ {fid}]}] + [ [integer] + {[ {tid}]}] + [$ [something] + {[$tgt {tgt}]}] + })) + +(define $follow-table (multiset follow)) + +;; +;; Demonstration code +;; +(define $user-data + { + + + }) + +(define $follow-data + { + + }) + +; Users whom "Egison_Lang" follows +(test (match-all [user-data follow-data user-data] [user-table follow-table user-table] + [[ ) _> + ) _> + ) _>] + ])) + +; Users who don't follow back "Egison_Lang" +(test (match-all [user-data follow-data user-data] [user-table follow-table user-table] + [[ ) _> + ) + ^ ) + _>> + ) _>] + ])) + +; Users who have interested in "Haskell" in the followers of followers of "Egison_Lang" +(test (match-all [user-data follow-data user-data] [user-table follow-table user-table] + [[ ) _> + ) + ) + _>> + > $txt)> ) _>] + ])) diff --git a/sample/tree.egi b/sample/tree.egi new file mode 100644 --- /dev/null +++ b/sample/tree.egi @@ -0,0 +1,89 @@ +;;; +;;; +;;; Tree demonstration +;;; +;;; + +;; +;; Matcher definition +;; +(define $tree + (lambda [$a $b] + (matcher + {[,$val [] + {[$tgt (match [val tgt] [(tree a b) (tree a b)] + {[[ ] {[]}] + [[_ _] {}]})]}] + [ b + {[ {x}] + [_ {}]}] + [ [a (list (tree a b))] ; Node whose children are seen as a list. + {[ {[x ts]}] + [_ {}]}] + [ [a (multiset (tree a b))] ; Node whose children are seen as a multiset. + {[ {[x ts]}] + [_ {}]}] + [ [(tree a b)] + {[$t (match-all t (tree a b) + [(loop $i [1 _] > $x) x])]}] + [$ [something] + {[$tgt {tgt}]}] + }))) + +;; +;; Demonstration code +;; +(define $tree-data + }> + + + + + }> + + + + + }> + }> + + + + }> + + + + + + }> + }>) + + +; All langauges +(test (unique/m string (match-all tree-data (tree string string) + [> x]))) + +; All langauges that belongs to Functional language +(test (unique/m string (match-all tree-data (tree string string) + [> _>>> x]))) + +; All langauges that belongs more than two categories +(test (unique/m string (match-all tree-data (tree string string) + [> + > + _>>> + x]))) + +; All categories that Egison belongs +(test (match-all tree-data (tree string string) + [(loop $i [1 $n] + > + ) + c])) diff --git a/sample/xml-test.egi b/sample/xml-test.egi new file mode 100644 --- /dev/null +++ b/sample/xml-test.egi @@ -0,0 +1,49 @@ +(load "lib/tree/xml.egi") + +(define $xml1 + + + + + + }> + }> + + + + + + }> + + + + + + }> + + + }> + }>) + + +;; List up all tags. +(test (match-all xml1 xml + [ _> [tag]])) +; {top middle1 middle2 middle3 bottom1 bottom4} + +;; List up all nodes which has more than two same child nodes. +(test (match-all xml1 xml + [>>> + [tag x]])) +; {[middle2 ] [middle2 ]} + +;; List up all nodes which has more than two same descendant nodes. +(test (match-all xml1 xml + [ + + _>>>> + [tag x]])) +; {[middle2 ] [middle2 ] [top ] [top ]} diff --git a/test/UnitTest.hs b/test/UnitTest.hs --- a/test/UnitTest.hs +++ b/test/UnitTest.hs @@ -20,12 +20,12 @@ runTestCase :: FilePath -> Test runTestCase file = TestLabel file . TestCase $ do - env <- primitiveEnv >>= loadLibraries + env <- primitiveEnv >>= loadCoreLibraries assertEgisonM $ do exprs <- loadFile file let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs env' <- recursiveBind env bindings - forM_ tests $ evalExpr' env' + forM_ tests $ evalExprDeep env' where assertEgisonM :: EgisonM a -> Assertion assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")