egison 3.2.18 → 3.2.19
raw patch · 9 files changed
+167/−123 lines, 9 files
Files
- egison.cabal +4/−2
- hs-src/Interpreter/egisoni.hs +10/−18
- hs-src/Language/Egison/Core.hs +70/−48
- hs-src/Language/Egison/Desugar.hs +39/−20
- hs-src/Language/Egison/Parser.hs +9/−9
- hs-src/Language/Egison/Primitives.hs +0/−9
- hs-src/Language/Egison/Types.hs +30/−11
- hs-src/Language/Egison/Util.hs +4/−5
- lib/core/natural-number.egi +1/−1
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 3.2.18+Version: 3.2.19 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 against unfree data types.@@ -56,15 +56,17 @@ Hs-Source-Dirs: test Main-Is: UnitTest.hs Build-Depends: egison, base >= 4.0 && < 5, transformers, mtl, Glob, HUnit, test-framework, test-framework-hunit+ Other-modules: Paths_egison Benchmark benchmark Type: exitcode-stdio-1.0 Hs-Source-Dirs: benchmark Main-Is: Benchmark.hs Build-Depends: egison, base >= 4.0 && < 5, deepseq, criterion >= 0.5, transformers, mtl+ Other-modules: Paths_egison Executable egison Main-is: egisoni.hs Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, strict-io, bytestring, unix- Other-modules: Paths_egison Hs-Source-Dirs: hs-src/Interpreter+ Other-modules: Paths_egison
hs-src/Interpreter/egisoni.hs view
@@ -1,17 +1,10 @@ module Main where -import Prelude hiding (catch)-import Control.Exception ( SomeException(..),- AsyncException(..),- catch, handle, throw)+import Control.Exception (handle) import Control.Concurrent-import Control.Applicative ((<$>), (<*>)) import Control.Monad.Error -import Data.List-import Data.Sequence (Seq, ViewL(..), ViewR(..), (><)) import qualified Data.Sequence as Sq-import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 () import Data.Version@@ -27,6 +20,7 @@ import System.IO import Language.Egison+import Language.Egison.Desugar import Language.Egison.Util main :: IO ()@@ -47,7 +41,7 @@ result <- evalEgisonTopExprs env [LoadFile file] either print (const $ return ()) result Options {optLoadOnly = False} -> do- result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))]+ result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (map (ElementExpr . StringExpr) args)))] either print (const $ return ()) result data Options = Options {@@ -118,16 +112,15 @@ putStrLn $ "Welcome to Egison Interpreter!" putStrLn $ "** Info **" putStrLn $ "We can use a \'Tab\' key to complete keywords on the interpreter."- putStrLn $ "If we type a \'Tab\' key after after a closed parenthesis, the next closed parenthesis will be completed."+ putStrLn $ "If we type a \'Tab\' key after a closed parenthesis, the next closed parenthesis will be completed." showByebyeMessage :: IO () showByebyeMessage = do putStrLn $ "Leaving Egison Interpreter."+ exitWith ExitSuccess onAbort :: EgisonError -> IO (Either EgisonError a)-onAbort e = do- let x = show e- return $ Left e+onAbort e = return $ Left e repl :: Env -> String -> IO () repl env prompt = do@@ -145,15 +138,15 @@ _ <- liftIO $ installHandler keyboardSignal (Catch (throwTo tid UserInterruption)) Nothing case input of Nothing -> return ()- Just (Left topExpr) -> do- result <- liftIO $ handle onAbort $ evalEgisonTopExpr env topExpr+ Just (Left (topExpr, _)) -> do+ result <- liftIO $ handle onAbort $ runEgisonTopExpr env topExpr case result of Left err -> do liftIO $ putStrLn $ show err loop env Right env' -> loop env'- Just (Right expr) -> do- result <- liftIO $ handle onAbort $ evalEgisonExpr env expr+ Just (Right (expr, _)) -> do+ result <- liftIO $ handle onAbort $ runEgisonExpr env expr case result of Left err -> do liftIO $ putStrLn $ show err@@ -161,5 +154,4 @@ Right val -> do liftIO $ putStrLn $ show val loop env-
hs-src/Language/Egison/Core.hs view
@@ -46,25 +46,19 @@ import Data.Foldable (toList) import Data.Traversable (mapM) import Data.IORef-import Data.List import Data.Maybe import qualified Data.HashMap.Lazy as HL import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Char8 () import qualified Data.ByteString.Lazy.Char8 as B -import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import System.Directory (doesFileExist) import Language.Egison.Types import Language.Egison.Parser-import Language.Egison.Desugar-import Paths_egison (getDataFileName) -- -- Evaluator@@ -129,16 +123,17 @@ evalExpr env (TupleExpr [expr]) = evalExpr env expr evalExpr env (TupleExpr exprs) = Intermediate . ITuple <$> mapM (newObjectRef env) exprs -evalExpr env (CollectionExpr inners) =- if Sq.null inners then- return . Value $ Collection Sq.empty- else- Intermediate . ICollection <$> (mapM fromInnerExpr inners >>= liftIO . newIORef)- where- fromInnerExpr :: InnerExpr -> EgisonM Inner- fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr- fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr+evalExpr _ (CollectionExpr []) = return . Value $ Collection Sq.empty +evalExpr env (CollectionExpr inners) = do+ inners' <- mapM fromInnerExpr inners+ innersSeq <- liftIO $ newIORef $ Sq.fromList inners'+ return $ Intermediate $ ICollection innersSeq+ where+ fromInnerExpr :: InnerExpr -> EgisonM Inner+ fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr+ fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr+ evalExpr env (ArrayExpr exprs) = do ref' <- mapM (newObjectRef env) exprs return . Intermediate . IArray $ IntMap.fromList $ zip (enumFromTo 1 (length exprs)) ref'@@ -265,7 +260,7 @@ evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do target <- newObjectRef env target matcher <- evalExpr env matcher >>= evalMatcherWHNF- result <- patternMatch BFSMode env pattern target matcher+ result <- patternMatch env pattern target matcher mmap (flip evalExpr expr . extendEnv env) result >>= fromMList where fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData@@ -280,7 +275,7 @@ target <- newObjectRef env target matcher <- evalExpr env matcher >>= evalMatcherWHNF let tryMatchClause (pattern, expr) cont = do- result <- patternMatch BFSMode env pattern target matcher+ result <- patternMatch env pattern target matcher case result of MCons bindings _ -> evalExpr (extendEnv env bindings) expr MNil -> cont@@ -291,7 +286,8 @@ arg <- evalExpr env arg applyFunc func arg -evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info+evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env BFSMode info+evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env DFSMode info evalExpr env (GenerateArrayExpr (name:[]) (TupleExpr (size:[])) expr) = generateArray env name size expr@@ -415,34 +411,63 @@ -- Pattern Match -- -patternMatch :: PMMode -> Env -> EgisonPattern -> ObjectRef -> Matcher ->- EgisonM (MList EgisonM [Binding]) -patternMatch mode env pattern target matcher =- processMState mode (MState env [] [] [MAtom pattern target matcher]) >>= (processMStates mode) . (:[])+patternMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM (MList EgisonM Match) +patternMatch env pattern target matcher = processMStates [msingleton $ MState env [] [] [MAtom pattern target matcher]] -processMStates :: PMMode -> [MList EgisonM MatchingState] -> EgisonM (MList EgisonM [Binding])-processMStates _ [] = return MNil-processMStates BFSMode streams = do- let (bindings, streams') = (catMaybes *** concat) . unzip $ map (processMStates' BFSMode) streams- mappend (fromList bindings) (sequence streams' >>= (processMStates BFSMode))-processMStates DFSMode (stream:streams) =- case processMStates' DFSMode stream of- (Nothing, streams2) -> do streams' <- sequence streams2- processMStates DFSMode (streams' ++ streams)- (Just bindings, streams2) -> do streams' <- sequence streams2- mappend (fromList [bindings]) (processMStates DFSMode (streams' ++ streams))+processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)+processMStates [] = return MNil+processMStates streams = do+ (matches, streams') <- extractMatches streams+ nextStreamss <- mapM processMStates' streams'+ let nextStreams = concat nextStreamss+ mappend (fromList matches) $ processMStates nextStreams+ where+ processMStates' :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]+ processMStates' MNil = return []+ processMStates' stream@(MCons state _) = do+ case topMAtom state of+ Nothing -> processMStatesBFS stream+ Just matom -> do+ case pmMode (getMatcher matom) of+ DFSMode -> processMStatesDFS stream+ BFSMode -> processMStatesBFS stream+ +processMStatesDFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)]+processMStatesDFS (MCons state stream) = do+ stream' <- processMState state+ newStream <- mappend stream' stream+ return [newStream]+ +processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)]+processMStatesBFS (MCons state stream) = do+ newStream <- processMState state+ newStream' <- stream+ return [newStream, newStream'] -processMStates' :: PMMode -> MList EgisonM MatchingState -> (Maybe [Binding], [EgisonM (MList EgisonM MatchingState)])-processMStates' _ MNil = (Nothing, [])-processMStates' _ (MCons (MState _ _ bindings []) states) = (Just bindings, [states])-processMStates' mode (MCons state states) = (Nothing, [processMState mode state, states])+extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])+extractMatches = extractMatches' ([], [])+ where+ extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])+ extractMatches' (xs, ys) [] = return (xs, ys)+ extractMatches' (xs, ys) ((MCons (MState _ _ bindings []) states):rest) = do+ states' <- states+ extractMatches' (xs ++ [bindings], ys ++ [states']) rest+ extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest -processMState :: PMMode -> MatchingState -> EgisonM (MList EgisonM MatchingState)-processMState mode state =+topMAtom :: MatchingState -> Maybe MatchingTree+topMAtom (MState _ _ _ (mAtom@(MAtom _ _ _):_)) = return mAtom+topMAtom (MState _ _ _ ((MNode _ mstate):_)) = topMAtom mstate+topMAtom (MState _ _ _ _) = Nothing++getMatcher :: MatchingTree -> Matcher+getMatcher (MAtom _ _ matcher) = matcher++processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState)+processMState state = do if isNotPat state then do let (state1, state2) = splitMState state- result <- processMStates mode [msingleton state1]+ result <- processMStates [msingleton state1] case result of MNil -> return $ msingleton state2 _ -> return MNil@@ -458,7 +483,7 @@ (MState env loops bindings [MAtom pattern target matcher], MState env loops bindings trees) splitMState (MState env loops bindings ((MNode penv state) : trees)) = let (state1, state2) = splitMState state- in (MState env loops bindings [MNode penv state1], MState env loops bindings (MNode penv state2 : trees)) + in (MState env loops bindings [MNode penv state1], MState env loops bindings (MNode penv state2 : trees)) processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState) processMState' state@(MState _ _ _ []) = throwError $ strMsg "should not reach here"@@ -542,7 +567,7 @@ >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern target matcher):trees)) _ -> case matcher of- matcher@(UserMatcher _ _) -> do+ matcher@(UserMatcher _ _ _) -> do (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher mfor targetss $ \ref -> do targets <- evalRef ref >>= fromTuple@@ -595,9 +620,7 @@ IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) _ -> throwError $ strMsg "something can only match with a pattern variable" --- _ -> throwError $ TypeMismatch "matcher" matcher-processMState' (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) =- return $ msingleton $ MState env loops bindings trees+processMState' (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) = return $ msingleton $ MState env loops bindings trees processMState' (MState env loops bindings ((MNode penv state@(MState env' loops' bindings' (tree:trees')):trees))) = do case tree of MAtom pattern target matcher -> do@@ -622,7 +645,7 @@ inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher])-inductiveMatch env pattern target (UserMatcher matcherEnv clauses) = do+inductiveMatch env pattern target (UserMatcher matcherEnv _ clauses) = do foldr tryPPMatchClause failPPPatternMatch clauses where tryPPMatchClause (pat, matchers, clauses) cont = do@@ -789,7 +812,7 @@ evalMatcherWHNF :: WHNFData -> EgisonM Matcher evalMatcherWHNF (Value matcher@Something) = return matcher-evalMatcherWHNF (Value matcher@(UserMatcher _ _)) = return matcher+evalMatcherWHNF (Value matcher@(UserMatcher _ _ _)) = return matcher evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms evalMatcherWHNF (Intermediate (ITuple refs)) = do whnfs <- mapM evalRef refs@@ -820,4 +843,3 @@ extractPrimitiveValue (Value val@(Integer _)) = return val extractPrimitiveValue (Value val@(Float _)) = return val extractPrimitiveValue whnf = throwError $ TypeMismatch "primitive value" whnf-
hs-src/Language/Egison/Desugar.hs view
@@ -13,6 +13,7 @@ DesugarM , runDesugarM , desugarTopExpr+ , desugarExpr , desugar ) where @@ -24,9 +25,7 @@ import Data.Set (Set) import Data.Char (toUpper) import Control.Monad.Error-import Control.Monad.State import Control.Monad.Reader-import Control.Monad.Identity import Language.Egison.Types type Subst = [(String, EgisonExpr)]@@ -37,15 +36,17 @@ runDesugarM :: DesugarM a -> Fresh (Either EgisonError a) runDesugarM = runErrorT . flip runReaderT [] . unDesugarM -desugarTopExpr :: EgisonTopExpr -> DesugarM EgisonTopExpr+desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr desugarTopExpr (Define name expr) = do- expr' <- desugar expr+ expr' <- liftEgisonM $ runDesugarM $ desugar expr return (Define name expr') desugarTopExpr (Test expr) = do- expr' <- desugar expr+ expr' <- liftEgisonM $ runDesugarM $ desugar expr return (Test expr') desugarTopExpr expr = return expr +desugarExpr :: EgisonExpr -> EgisonM EgisonExpr+desugarExpr expr = liftEgisonM $ runDesugarM $ desugar expr desugar :: EgisonExpr -> DesugarM EgisonExpr desugar (AlgebraicDataMatcherExpr patterns) = do@@ -89,7 +90,7 @@ genMatcherClause pattern = do (ppat, matchers) <- genPrimitivePatPat pattern (dpat, body) <- genPrimitiveDataPat pattern- return (ppat, TupleExpr matchers, [(dpat, CollectionExpr (Sq.singleton . ElementExpr . TupleExpr $ body)), (PDWildCard, matchingFailure)])+ return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)]) where genPrimitivePatPat :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, [EgisonExpr])@@ -108,13 +109,13 @@ genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genSomethingClause = - return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr . Sq.singleton $ ElementExpr (VarExpr "tgt"))])+ return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr "tgt")])]) matchingSuccess :: EgisonExpr- matchingSuccess = CollectionExpr . Sq.singleton. ElementExpr $ TupleExpr []+ matchingSuccess = CollectionExpr [ElementExpr $ TupleExpr []] matchingFailure :: EgisonExpr- matchingFailure = CollectionExpr Sq.empty+ matchingFailure = CollectionExpr [] desugar (MatchAllLambdaExpr matcher clause) = do name <- fresh@@ -144,18 +145,18 @@ exprs' <- mapM desugar exprs return $ TupleExpr exprs' -desugar expr@(CollectionExpr seq) =- case Sq.viewl seq of- EmptyL -> return expr- ElementExpr seqHead :< seqTail -> do- seqHead' <- desugar seqHead- (CollectionExpr seqTail') <- desugar (CollectionExpr seqTail)- return $ CollectionExpr (ElementExpr seqHead' <| seqTail')- SubCollectionExpr seqHead :< seqTail -> do- seqHead' <- desugar seqHead- (CollectionExpr seqTail') <- desugar (CollectionExpr seqTail)- return $ CollectionExpr (SubCollectionExpr seqHead' <| seqTail')+desugar expr@(CollectionExpr []) = return expr +desugar (CollectionExpr ((ElementExpr elm):inners)) = do+ elm' <- desugar elm+ (CollectionExpr inners') <- desugar (CollectionExpr inners)+ return $ CollectionExpr (ElementExpr elm':inners')++desugar (CollectionExpr ((SubCollectionExpr sub):inners)) = do+ sub' <- desugar sub+ (CollectionExpr inners') <- desugar (CollectionExpr inners)+ return $ CollectionExpr (SubCollectionExpr sub':inners')+ desugar (LambdaExpr names expr) = do expr' <- desugar expr return $ LambdaExpr names expr'@@ -197,6 +198,24 @@ expr' <- desugar expr return $ DoExpr binds' expr' +desugar (ApplyExpr (VarExpr "+") expr) = do+ expr' <- desugar expr+ case expr' of+ args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "+") args+ (TupleExpr args) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "+"), (IntegerExpr 0), (CollectionExpr (map ElementExpr args))])++desugar (ApplyExpr (VarExpr "-") expr) = do+ expr' <- desugar expr+ case expr' of+ args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "-") args+ (TupleExpr (x:args)) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "-"), x, (CollectionExpr (map ElementExpr args))])++desugar (ApplyExpr (VarExpr "*") expr) = do+ expr' <- desugar expr+ case expr' of+ args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "*") args+ (TupleExpr args) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "*"), (IntegerExpr 1), (CollectionExpr (map ElementExpr args))])+ desugar (ApplyExpr expr0 expr1) = do expr0' <- desugar expr0 expr1' <- desugar expr1
hs-src/Language/Egison/Parser.hs view
@@ -31,11 +31,9 @@ import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) import System.Directory (doesFileExist)-import System.IO import qualified Data.Sequence as Sq import Data.Either-import Data.Set (Set) import Data.Char (isLower, isUpper) import qualified Data.Set as Set import Data.Traversable (mapM)@@ -43,7 +41,6 @@ import Text.Parsec import Text.Parsec.String-import Text.Parsec.Combinator import qualified Text.Parsec.Token as P import Language.Egison.Types@@ -51,10 +48,10 @@ import Paths_egison (getDataFileName) readTopExprs :: String -> EgisonM [EgisonTopExpr]-readTopExprs = liftEgisonM . runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs+readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs readTopExpr :: String -> EgisonM EgisonTopExpr-readTopExpr = liftEgisonM . runDesugarM . either throwError desugarTopExpr . parseTopExpr+readTopExpr = either throwError desugarTopExpr . parseTopExpr readExprs :: String -> EgisonM [EgisonExpr] readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs@@ -157,6 +154,7 @@ <|> matchAllLambdaExpr <|> matchLambdaExpr <|> matcherExpr+ <|> matcherDFSExpr <|> applyExpr <|> algebraicDataMatcherExpr <|> generateArrayExpr@@ -174,7 +172,7 @@ tupleExpr = brackets $ TupleExpr <$> sepEndBy expr whiteSpace collectionExpr :: Parser EgisonExpr-collectionExpr = braces $ CollectionExpr . Sq.fromList <$> sepEndBy innerExpr whiteSpace+collectionExpr = braces $ CollectionExpr <$> sepEndBy innerExpr whiteSpace where innerExpr :: Parser InnerExpr innerExpr = (char '@' >> SubCollectionExpr <$> expr)@@ -215,6 +213,9 @@ matcherExpr :: Parser EgisonExpr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses +matcherDFSExpr :: Parser EgisonExpr+matcherDFSExpr = keywordMatcher >> MatcherDFSExpr <$> ppMatchClauses+ ppMatchClauses :: Parser MatcherInfo ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace @@ -489,6 +490,7 @@ , "match-all-lambda" , "match-lambda" , "matcher"+ , "matcher-dfs" , "do" , "io" , "algebraic-data-matcher"@@ -538,14 +540,12 @@ keywordMatch = reserved "match" keywordMatchLambda = reserved "match-lambda" keywordMatcher = reserved "matcher"+keywordMatcherDFS = reserved "matcher-dfs" keywordDo = reserved "do" keywordIo = reserved "io" keywordSomething = reserved "something" keywordUndefined = reserved "undefined" keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher"---keywordisEmpty = reserved "empty?"---keywordUnCons = reserved "uncons"---keywordUnSnoc = reserved "unsnoc" keywordGenerateArray = reserved "generate-array" keywordArraySize = reserved "array-size" keywordArrayRef = reserved "array-ref"
hs-src/Language/Egison/Primitives.hs view
@@ -11,12 +11,10 @@ module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where import Control.Arrow-import Control.Applicative import Control.Monad.Error import Control.Monad.Trans.Maybe import Data.IORef-import qualified Data.Array as A import Data.Ratio import System.IO@@ -24,14 +22,7 @@ import qualified Data.Sequence as Sq -import System.IO.Unsafe-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BC import qualified Data.Text as T-import Data.Maybe--import Control.Monad -- {-- -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite
hs-src/Language/Egison/Types.hs view
@@ -42,7 +42,9 @@ , extendEnv , refVar -- * Pattern matching+ , Match , PMMode (..)+ , pmMode , MatchingState (..) , MatchingTree (..) , PatternBinding (..)@@ -95,7 +97,6 @@ import qualified Data.HashMap.Strict as HashMap import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Char8 () import qualified Data.ByteString.Lazy.Char8 as B @@ -130,7 +131,7 @@ | IndexedExpr EgisonExpr [EgisonExpr] | InductiveDataExpr String [EgisonExpr] | TupleExpr [EgisonExpr]- | CollectionExpr (Seq InnerExpr)+ | CollectionExpr [InnerExpr] | ArrayExpr [EgisonExpr] | HashExpr [(EgisonExpr, EgisonExpr)] @@ -147,6 +148,7 @@ | MatchAllLambdaExpr EgisonExpr MatchClause | MatcherExpr MatcherInfo+ | MatcherDFSExpr MatcherInfo | DoExpr [BindingExpr] EgisonExpr | IoExpr EgisonExpr@@ -228,7 +230,7 @@ | Array (IntMap EgisonValue) | IntHash (HashMap Integer EgisonValue) | StrHash (HashMap ByteString EgisonValue)- | UserMatcher Env MatcherInfo+ | UserMatcher Env PMMode MatcherInfo | Func Env [String] EgisonExpr | PatternFunc Env [String] EgisonPattern | PrimitiveFunc PrimitiveFunc@@ -264,7 +266,7 @@ show (Array vals) = "[|" ++ unwords (map show $ IntMap.elems vals) ++ "|]" show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ B.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"- show (UserMatcher _ _) = "#<matcher>"+ show (UserMatcher _ _ _) = "#<matcher>" show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)" show (PatternFunc _ _ _) = "#<pattern-function>" show (PrimitiveFunc _) = "#<primitive-function>"@@ -372,20 +374,20 @@ fromFloatValue val = throwError $ TypeMismatch "float" (Value val) fromPortValue :: EgisonValue -> Either EgisonError Handle-fromPortValue (Port handle) = return handle+fromPortValue (Port h) = return h fromPortValue val = throwError $ TypeMismatch "port" (Value val) -- -- Internal Data -- +-- |For memoization+type ObjectRef = IORef Object+ data Object = Thunk (EgisonM WHNFData) | WHNF WHNFData --- |For memoization-type ObjectRef = IORef Object- data WHNFData = Intermediate Intermediate | Value EgisonValue@@ -411,11 +413,17 @@ show (Intermediate (IIntHash _)) = "{|...|}" show (Intermediate (IStrHash _)) = "{|...|}" +instance Show Object where+ show (Thunk _) = "#<thunk>"+ show (WHNF whnf) = show whnf+ -- -- Extract data from WHNF ---class EgisonWHNF a where+class (Egison a) => EgisonWHNF a where+ toWHNF :: a -> WHNFData fromWHNF :: WHNFData -> EgisonM a+ toWHNF = Value . toEgison instance EgisonWHNF Char where fromWHNF = liftError . fromCharWHNF@@ -456,9 +464,13 @@ fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf fromPortWHNF :: WHNFData -> Either EgisonError Handle-fromPortWHNF (Value (Port handle)) = return handle+fromPortWHNF (Value (Port h)) = return h fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf +class (EgisonWHNF a) => EgisonObject a where+ toObject :: a -> Object+ toObject = WHNF . toWHNF+ -- -- Environment --@@ -481,8 +493,15 @@ -- Pattern Match -- +type Match = [Binding]+ data PMMode = BFSMode | DFSMode +pmMode :: Matcher -> PMMode+pmMode (UserMatcher _ mode _) = mode+pmMode (Tuple _) = BFSMode+pmMode Something = BFSMode+ data MatchingState = MState Env [LoopContext] [Binding] [MatchingTree] data MatchingTree =@@ -513,7 +532,7 @@ deriving Typeable instance Show EgisonError where- show (Parser error) = "Parse error at: " ++ error+ show (Parser err) = "Parse error at: " ++ err show (UnboundVariable var) = "Unbound variable: " ++ var show (TypeMismatch expected found) = "Expected " ++ expected ++ ", but found: " ++ show found
hs-src/Language/Egison/Util.hs view
@@ -16,12 +16,11 @@ import Language.Egison.Types import Language.Egison.Parser - -- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExpr :: String -> InputT IO (Maybe (Either EgisonTopExpr EgisonExpr))+getEgisonExpr :: String -> InputT IO (Maybe (Either (String, EgisonTopExpr) (String, EgisonExpr))) getEgisonExpr prompt = getEgisonExpr' "" where- getEgisonExpr' :: String -> InputT IO (Maybe (Either EgisonTopExpr EgisonExpr))+ getEgisonExpr' :: String -> InputT IO (Maybe (Either (String, EgisonTopExpr) (String, EgisonExpr))) getEgisonExpr' prev = do mLine <- case prev of "" -> getInputLine prompt@@ -40,11 +39,11 @@ Left err -> do liftIO $ putStrLn $ show err getEgisonExpr prompt- Right expr -> return $ Just $ Right expr+ Right expr -> return $ Just $ Right (input, expr) Left err -> do liftIO $ putStrLn $ show err getEgisonExpr prompt- Right topExpr -> return $ Just $ Left topExpr+ Right topExpr -> return $ Just $ Left (input, topExpr) -- |Complete Egison keywords
lib/core/natural-number.egi view
@@ -39,7 +39,7 @@ (define $divisor? (lambda [$n $d]- (eq-i? 0 (remainder n d))))+ (eq? 0 (remainder n d)))) (define $gcd