egison 3.9.1 → 3.9.2
raw patch · 19 files changed
+1442/−1015 lines, 19 filesdep +megaparsecdep +parser-combinatorsdep −parallel
Dependencies added: megaparsec, parser-combinators
Dependencies removed: parallel
Files
- LICENSE +1/−1
- benchmark/Benchmark.hs +11/−16
- egison.cabal +60/−8
- hs-src/Interpreter/egison.hs +29/−33
- hs-src/Language/Egison.hs +8/−5
- hs-src/Language/Egison/Core.hs +26/−27
- hs-src/Language/Egison/Desugar.hs +152/−205
- hs-src/Language/Egison/Lexer.x +0/−261
- hs-src/Language/Egison/MathOutput.hs +0/−3
- hs-src/Language/Egison/Parser.hs +13/−27
- hs-src/Language/Egison/ParserNonS.hs +18/−31
- hs-src/Language/Egison/ParserNonS2.hs +783/−0
- hs-src/Language/Egison/ParserNonS2.y +0/−304
- hs-src/Language/Egison/Primitives.hs +164/−7
- hs-src/Language/Egison/Types.hs +85/−26
- hs-src/Language/Egison/Util.hs +6/−26
- lib/core/order.egi +7/−0
- lib/core/string.egi +6/−6
- test/Test.hs +73/−29
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2017, Satoshi Egi+Copyright (c) 2011-2019, Satoshi Egi Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),
benchmark/Benchmark.hs view
@@ -3,25 +3,20 @@ import Control.Applicative ((<$>), (<*>)) import Control.Applicative import Control.DeepSeq (NFData (rnf))-import Control.Monad.Error-import Criterion.Config+import Control.Monad.Except+import Criterion import Criterion.Main import Language.Egison -runEgisonFile :: String -> IO (Either EgisonError Env)-runEgisonFile path = loadPrimitives nullEnv >>= loadLibraries >>= flip (loadEgisonFile defaultOption) path--config :: Config-config = defaultConfig { cfgSamples = ljust 3- , cfgPerformGC = ljust True }+runEgisonFile :: String -> IO ()+runEgisonFile path = initialEnv defaultOption >>= flip (loadEgisonFile defaultOption) path >> return () main :: IO ()-main = defaultMainWith config (return ())- [ bgroup "fact" [ bench "30000" $ runEgisonFile "benchmark/fact-30000.egi" ]- , bgroup "collection"- [ bench "cons-bench" $ runEgisonFile "benchmark/collection-bench-cons.egi"- , bench "cons-bench-large" $ runEgisonFile "benchmark/collection-bench-cons-large.egi"- , bench "snoc-bench" $ runEgisonFile "benchmark/collection-bench-snoc.egi"- ]- ]+main = defaultMainWith defaultConfig+ [ bgroup "fact" [ bench "30000" $ nfIO $ runEgisonFile "benchmark/fact-30000.egi" ]+ , bgroup "collection"+ [ bench "cons-bench" $ nfIO $ runEgisonFile "benchmark/collection-bench-cons.egi"+ , bench "cons-bench-large" $ nfIO $ runEgisonFile "benchmark/collection-bench-cons-large.egi"+ , bench "snoc-bench" $ nfIO $ runEgisonFile "benchmark/collection-bench-snoc.egi"+ ]]
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 3.9.1+Version: 3.9.2 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language.@@ -51,7 +51,7 @@ Homepage: http://www.egison.org License: MIT License-file: LICENSE-Author: Satoshi Egi, Ryo Tanaka, Takahisa Watanabe, Kentaro Honda, Mayuko Kori+Author: Satoshi Egi, Ryo Tanaka, Takahisa Watanabe, Kentaro Honda, Mayuko Kori, Momoko Hattori Maintainer: Satoshi Egi <egi@egison.org> Category: Compilers/Interpreters Build-type: Simple@@ -68,7 +68,27 @@ location: https://github.com/egison/egison.git Library- Build-Depends: base >= 4.7 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl >=2.2.1, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process, vector, parallel, split, hashable+ Build-Depends:+ base >= 4.7 && < 5+ , array+ , random+ , containers+ , unordered-containers+ , haskeline+ , transformers+ , mtl >=2.2.1+ , parsec >= 3.0+ , megaparsec >= 7.0.0+ , parser-combinators+ , directory+ , ghc+ , ghc-paths+ , text+ , regex-tdfa+ , process+ , vector+ , split+ , hashable if !impl(ghc > 8.0) Build-Depends: fail Hs-Source-Dirs: hs-src@@ -76,8 +96,8 @@ Language.Egison Language.Egison.Core Language.Egison.Desugar- Language.Egison.Types Language.Egison.Lexer+ Language.Egison.Types Language.Egison.Parser Language.Egison.ParserNonS Language.Egison.ParserNonS2@@ -85,26 +105,58 @@ Language.Egison.Util Language.Egison.MathOutput Other-modules: Paths_egison- build-tools: happy >= 1.17.1, alex+ Autogen-modules: Language.Egison.Lexer ghc-options: -O3 Test-Suite test Type: exitcode-stdio-1.0 Hs-Source-Dirs: test Main-Is: Test.hs- Build-Depends: egison, base >= 4.0 && < 5, transformers, mtl, Glob, HUnit, test-framework, test-framework-hunit, filepath+ Build-Depends:+ egison+ , base >= 4.0 && < 5+ , transformers+ , mtl+ , Glob+ , HUnit+ , test-framework+ , test-framework-hunit+ , filepath 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+ Build-Depends:+ egison+ , base >= 4.0 && < 5+ , deepseq+ , criterion >= 0.5+ , transformers+ , mtl Other-modules: Paths_egison Executable egison Main-is: egison.hs- Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.1, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process, vector, optparse-applicative+ Build-depends:+ egison+ , base >= 4.0 && < 5+ , array+ , containers+ , unordered-containers+ , haskeline+ , transformers+ , mtl+ , parsec >= 3.1+ , directory+ , ghc+ , ghc-paths+ , filepath+ , text+ , process+ , vector+ , optparse-applicative if !impl(ghc > 8.0) Build-Depends: semigroups Hs-Source-Dirs: hs-src/Interpreter
hs-src/Interpreter/egison.hs view
@@ -10,18 +10,14 @@ import Prelude hiding (catch) import Data.Char-import Data.List (intercalate) import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Version -import System.Console.GetOpt import System.Console.Haskeline hiding (catch, handle, throwTo) import System.Directory (getHomeDirectory)-import System.Environment-import System.Exit (ExitCode (..), exitFailure,- exitSuccess)+import System.Exit (exitFailure, exitSuccess) import System.FilePath ((</>)) import System.IO @@ -117,7 +113,7 @@ <> long "new-syntax" <> help "Use non-S-expressoin syntax") <*> flag False True- (long "happy"+ (long "N2" <> help "[experimental] Use new lexer and parser") readFieldOption :: String -> (String, String)@@ -145,33 +141,33 @@ case mEnv of Left err -> print err Right env ->- case optEvalString opts of- Just expr ->- if optTsvOutput opts- then f opts env $ "(execute (each (compose show-tsv print) " ++ expr ++ "))"- else do ret <- runEgisonExpr opts env expr- case ret of- Left err -> hPrint stderr err >> exitFailure- Right val -> print val >> exitSuccess- Nothing ->- case optExecuteString opts of- Just cmd -> f opts env $ "(execute " ++ cmd ++ ")"- Nothing ->- case optSubstituteString opts of- Just sub -> f opts env $ "(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if optTsvOutput opts then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ unwords (map fst $ optFieldInfo opts) ++ "} {" ++ unwords (map snd $ optFieldInfo opts) ++ "})]} (" ++ sub ++ " SH.input))))"- Nothing ->- case optExecFile opts of- Nothing -> when (optShowBanner opts) showBanner >> repl opts env >> when (optShowBanner opts) showByebyeMessage >> exitSuccess- Just (file, args) ->- if optTestOnly opts then do- result <- if optNoIO opts- then do input <- readFile file- runEgisonTopExprs opts env input- else evalEgisonTopExprs opts env [LoadFile file]- either print (const $ return ()) result- else do- result <- evalEgisonTopExprs opts env [LoadFile file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map ((ElementExpr . StringExpr) . T.pack) args)))]- either print (const $ return ()) result+ case opts of+ EgisonOpts { optEvalString = Just expr }+ | optTsvOutput opts ->+ f opts env $ "(execute (each (compose show-tsv print) " ++ expr ++ "))"+ | otherwise -> do+ ret <- runEgisonExpr opts env expr+ case ret of+ Left err -> hPrint stderr err >> exitFailure+ Right val -> print val >> exitSuccess+ EgisonOpts { optExecuteString = Just cmd } ->+ f opts env $ "(execute " ++ cmd ++ ")"+ EgisonOpts { optSubstituteString = Just sub } ->+ let expr = "(load \"lib/core/shell.egi\") "+ ++ "(execute (each (compose " ++ (if optTsvOutput opts then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ unwords (map fst $ optFieldInfo opts) ++ "} {" ++ unwords (map snd $ optFieldInfo opts) ++ "})]} (" ++ sub ++ " SH.input))))"+ in f opts env expr+ EgisonOpts { optExecFile = Nothing } ->+ when (optShowBanner opts) showBanner >> repl opts env >> when (optShowBanner opts) showByebyeMessage >> exitSuccess+ EgisonOpts { optExecFile = Just (file, args) }+ | optTestOnly opts -> do+ result <- if optNoIO opts+ then do input <- readFile file+ runEgisonTopExprs opts env input+ else evalEgisonTopExprs opts env [LoadFile file]+ either print (const $ return ()) result+ | otherwise -> do+ result <- evalEgisonTopExprs opts env [LoadFile file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map ((ElementExpr . StringExpr) . T.pack) args)))]+ either print (const $ return ()) result where isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = notElem lang ["asciimath", "latex", "mathematica", "maxima"] isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False
hs-src/Language/Egison.hs view
@@ -80,28 +80,28 @@ -- |eval an Egison expression. Input is a Haskell string. runEgisonExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError EgisonValue) runEgisonExpr opts env input- | optUseHappy opts = fromEgisonM $ ParserNonS2.readExpr input >>= evalExprDeep env+ | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readExpr input >>= evalExprDeep env | optSExpr opts = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env | otherwise = fromEgisonM $ ParserNonS.readExpr input >>= evalExprDeep env -- |eval an Egison top expression. Input is a Haskell string. runEgisonTopExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env) runEgisonTopExpr opts env input- | optUseHappy opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr opts env+ | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr opts env | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr opts env | otherwise = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr opts env -- |eval an Egison top expression. Input is a Haskell string. runEgisonTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env)) runEgisonTopExpr' opts st input- | optUseHappy opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr' opts st+ | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr' opts st | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' opts st | otherwise = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' opts st -- |eval Egison top expressions. Input is a Haskell string. runEgisonTopExprs :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env) runEgisonTopExprs opts env input- | optUseHappy opts = fromEgisonM $ ParserNonS2.readTopExprs input >>= evalTopExprs opts env+ | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readTopExprs input >>= evalTopExprs opts env | optSExpr opts = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs opts env | otherwise = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs opts env @@ -116,7 +116,10 @@ -- |Environment that contains core libraries initialEnv :: EgisonOpts -> IO Env initialEnv opts = do- env <- if optNoIO opts then primitiveEnvNoIO else primitiveEnv+ env <- if optNoIO opts then if optUseNonS2 opts then primitiveEnvNoIO'+ else primitiveEnvNoIO+ else if optUseNonS2 opts then primitiveEnv'+ else primitiveEnv ret <- evalEgisonTopExprs defaultOption env $ map Load coreLibraries case ret of Left err -> do
hs-src/Language/Egison/Core.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-} {- | Module : Language.Egison.Core@@ -41,7 +42,6 @@ import Prelude hiding (mapM, mappend, mconcat) -import Control.Applicative import Control.Arrow import Control.Monad (when) import Control.Monad.Except hiding (mapM)@@ -51,28 +51,19 @@ import Data.Foldable (toList) import Data.IORef-import Data.List (any, drop, last, nub, partition)-import Data.List.Split (oneOf, split)+import Data.List (partition) import Data.Maybe-import Data.Ratio import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) import qualified Data.Sequence as Sq import Data.Traversable (mapM) -import Data.Array ((!)) import qualified Data.Array as Array import qualified Data.HashMap.Lazy as HL-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Map (Map, assocs, empty, singleton,- unionWith, unionsWith, (!))-import qualified Data.Map as M import qualified Data.Vector as V import Data.Text (Text) import qualified Data.Text as T -import Language.Egison.MathOutput import Language.Egison.Parser as Parser import Language.Egison.ParserNonS as ParserNonS import Language.Egison.ParserNonS2 as ParserNonS2@@ -92,12 +83,18 @@ LoadFile file -> if optNoIO opts then throwError $ Default "No IO support"- else do exprs' <- if optUseHappy opts then ParserNonS2.loadFile file else if optSExpr opts then Parser.loadFile file else ParserNonS.loadFile file+ else do exprs' <- if+ | optUseNonS2 opts -> ParserNonS2.loadFile file+ | optSExpr opts -> Parser.loadFile file+ | otherwise -> ParserNonS.loadFile file collectDefs opts (exprs' ++ exprs) bindings rest Load file -> if optNoIO opts then throwError $ Default "No IO support"- else do exprs' <- if optUseHappy opts then ParserNonS2.loadLibraryFile file else if optSExpr opts then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file+ else do exprs' <- if+ | optUseNonS2 opts -> ParserNonS2.loadLibraryFile file+ | optSExpr opts -> Parser.loadLibraryFile file+ | otherwise -> ParserNonS.loadLibraryFile file collectDefs opts (exprs' ++ exprs) bindings rest collectDefs _ [] bindings rest = return (bindings, reverse rest) @@ -156,7 +153,7 @@ refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" $ show var))) return (refVar env var) -evalExpr env (PartialVarExpr n) = evalExpr env (VarExpr $ stringToVar ("::" ++ show n))+evalExpr env (PartialVarExpr n) = evalExpr env (stringToVarExpr ("::" ++ show n)) evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] evalExpr env (InductiveDataExpr name exprs) =@@ -429,7 +426,7 @@ nth n = let pattern = TuplePat $ flip map [1..k] $ \i -> if i == n then PatVar (stringToVar "#_") else WildCard- in MatchExpr target matcher [(pattern, VarExpr $ stringToVar "#_")]+ in MatchExpr target matcher [(pattern, stringToVarExpr "#_")] return ((var, expr) : map (second nth) (zip names [1..])) genVar :: State Int Var@@ -488,12 +485,12 @@ evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do- let body = foldr genLet (ApplyExpr expr $ TupleExpr [VarExpr $ stringToVar "#1"]) bindings+ let body = foldr genLet (ApplyExpr expr $ TupleExpr [stringToVarExpr "#1"]) bindings applyFunc env (Value $ Func Nothing env ["#1"] body) $ Value World where genLet (names, expr) expr' =- LetExpr [(map stringToVar ["#1", "#2"], ApplyExpr expr $ TupleExpr [VarExpr $ stringToVar "#1"])] $- LetExpr [(names, VarExpr $ stringToVar "#2")] expr'+ LetExpr [(map stringToVar ["#1", "#2"], ApplyExpr expr $ TupleExpr [stringToVarExpr "#1"])] $+ LetExpr [(names, stringToVarExpr "#2")] expr' evalExpr env (IoExpr expr) = do io <- evalExpr env expr@@ -819,7 +816,7 @@ let argnum = length tds subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum] supjs = map (Superscript . symbolScalarData symId . show) [1 .. argnum]- dot <- evalExpr env (VarExpr $ stringToVar ".")+ dot <- evalExpr env (stringToVarExpr ".") makeITuple (Value (TensorData (Tensor s1 t1 (i1 ++ supjs))):map (Intermediate .ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)) >>= applyFunc env dot else throwError $ Default "applyfunc" @@ -831,7 +828,7 @@ let argnum = length tds subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum] supjs = map (Superscript . symbolScalarData symId . show) [1 .. argnum]- dot <- evalExpr env (VarExpr $ stringToVar ".")+ dot <- evalExpr env (stringToVarExpr ".") makeITuple (map Intermediate (ITensor (Tensor s1 t1 (i1 ++ supjs)):map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds))) >>= applyFunc env dot else throwError $ Default "applyfunc" @@ -1209,13 +1206,15 @@ (carEndsRef, cdrEndsRef) <- fromJust <$> runMaybeT (unconsCollection ends) b2 <- evalRef cdrEndsRef >>= isEmptyCollection carEndsNum <- evalRef carEndsRef >>= fromWHNF- if startNum > carEndsNum- then return MNil- else if startNum == carEndsNum- then if b2- then return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees)]- else return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees), MState env (LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]- else return $ fromList [MState env (LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]+ return $ if+ | startNum > carEndsNum -> MNil+ | startNum == carEndsNum && b2 ->+ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees)]+ | startNum == carEndsNum ->+ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees),+ MState env (LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]+ | otherwise ->+ fromList [MState env (LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)] SeqNilPat -> throwError =<< EgisonBug "should not reach here (seq nil pattern)" <$> getFuncNameStack SeqConsPat pattern pattern' -> return $ msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher] LaterPatVar ->
hs-src/Language/Egison/Desugar.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-} {- | Module : Language.Egison.Desugar@@ -19,18 +20,16 @@ , desugar ) where -import Control.Applicative (Applicative, pure, (*>), (<$>), (<*),- (<*>))+import Control.Applicative (Applicative, pure, (<$>), (<*>)) import Control.Monad.Except import Control.Monad.Fail import Control.Monad.Reader import Data.Char (toUpper)-import Data.List (span)-import Data.Maybe (fromMaybe)-import Data.Sequence (ViewL (..), (<|))-import qualified Data.Sequence as Sq+import Data.List (find, span)+import Data.Maybe (fromJust, fromMaybe) import Data.Set (Set) import qualified Data.Set as S+ import Language.Egison.Types type Subst = [(String, EgisonExpr)]@@ -81,7 +80,7 @@ genMainClause patterns matcher = do clauses <- genClauses patterns return (PPValuePat "val", TupleExpr []- ,[(PDPatVar "tgt", MatchExpr (TupleExpr [VarExpr $ stringToVar "val", VarExpr $ stringToVar "tgt"])+ ,[(PDPatVar "tgt", MatchExpr (TupleExpr [stringToVarExpr "val", stringToVarExpr "tgt"]) (TupleExpr [matcher, matcher]) clauses)]) where@@ -123,7 +122,7 @@ genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genSomethingClause =- return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr $ stringToVar "tgt")])])+ return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (stringToVarExpr "tgt")])]) matchingSuccess :: EgisonExpr matchingSuccess = CollectionExpr [ElementExpr $ TupleExpr []]@@ -133,11 +132,11 @@ desugar (MatchAllLambdaExpr matcher clauses) = do name <- fresh- desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (VarExpr $ stringToVar name) matcher clauses)+ desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (stringToVarExpr name) matcher clauses) desugar (MatchLambdaExpr matcher clauses) = do name <- fresh- desugar $ LambdaExpr [TensorArg name] (MatchExpr (VarExpr $ stringToVar name) matcher clauses)+ desugar $ LambdaExpr [TensorArg name] (MatchExpr (stringToVarExpr name) matcher clauses) desugar (ArrayRefExpr expr nums) = case nums of@@ -145,24 +144,30 @@ _ -> desugar $ IndexedExpr True expr [Subscript nums] desugar (IndexedExpr b expr indices)- | endWithThreeDots expr = case expr of- (VarExpr name) -> let x = show name in desugar $ IndexedExpr False (VarExpr $ stringToVar $ take (length x - 3) x) indices- | otherwise = case indices of- [Subscript x, DotSubscript y] -> case (x, y) of- (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [x, y]))- (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do- k <- fresh- return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "map")- (TupleExpr [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ VarExpr $ stringToVar k]),- ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [fromIndexToExpr n1, fromIndexToExpr n2])]))- [Superscript x, DotSupscript y] -> case (x, y) of- (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [x, y]))- (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do- k <- fresh- return $ SuprefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "map")- (TupleExpr [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ VarExpr $ stringToVar k]),- ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [fromIndexToExpr n1, fromIndexToExpr n2])]))- _ -> IndexedExpr b <$> desugar expr <*> mapM desugarIndex indices+ | endWithThreeDots expr =+ case expr of+ VarExpr name ->+ let x = show name+ in desugar $ IndexedExpr False (stringToVarExpr $ take (length x - 3) x) indices+ | otherwise =+ case indices of+ [Subscript x, DotSubscript y] ->+ case (x, y) of+ (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (makeApply "between" [x, y])+ (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do+ k <- fresh+ return $ SubrefsExpr b expr (makeApply "map"+ [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ stringToVarExpr k]),+ makeApply "between" [fromIndexToExpr n1, fromIndexToExpr n2]])+ [Superscript x, DotSupscript y] ->+ case (x, y) of+ (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (makeApply "between" [x, y])+ (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do+ k <- fresh+ return $ SuprefsExpr b expr (makeApply "map"+ [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ stringToVarExpr k]),+ makeApply "between" [fromIndexToExpr n1, fromIndexToExpr n2]])+ _ -> IndexedExpr b <$> desugar expr <*> mapM desugarIndex indices where endWithThreeDots :: EgisonExpr -> Bool endWithThreeDots (VarExpr name) = take 3 (reverse (show name)) == "..."@@ -178,38 +183,37 @@ desugar (SuprefsExpr bool expr1 expr2) = SuprefsExpr bool <$> desugar expr1 <*> desugar expr2 +desugar (UserrefsExpr bool expr1 expr2) =+ UserrefsExpr bool <$> desugar expr1 <*> desugar expr2+ desugar (PowerExpr expr1 expr2) = do expr1' <- desugar expr1 expr2' <- desugar expr2- return $ ApplyExpr (VarExpr $ stringToVar "**") (TupleExpr [expr1', expr2'])+ return $ ApplyExpr (stringToVarExpr "**") (TupleExpr [expr1', expr2']) -desugar (ArrayBoundsExpr expr) = do- expr' <- desugar expr- return $ ArrayBoundsExpr expr'+desugar (ArrayBoundsExpr expr) =+ ArrayBoundsExpr <$> desugar expr -desugar (InductiveDataExpr name exprs) = do- exprs' <- mapM desugar exprs- return $ InductiveDataExpr name exprs'+desugar (InductiveDataExpr name exprs) =+ InductiveDataExpr name <$> mapM desugar exprs -desugar (TupleExpr exprs) = do- exprs' <- mapM desugar exprs- return $ TupleExpr exprs'+desugar (TupleExpr exprs) =+ TupleExpr <$> mapM desugar exprs desugar expr@(CollectionExpr []) = return expr desugar (CollectionExpr (ElementExpr elm:inners)) = do- elm' <- desugar elm- (CollectionExpr inners') <- desugar (CollectionExpr inners)- return $ CollectionExpr (ElementExpr elm':inners')+ 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')+ sub' <- desugar sub+ (CollectionExpr inners') <- desugar (CollectionExpr inners)+ return $ CollectionExpr (SubCollectionExpr sub':inners') -desugar (VectorExpr exprs) = do- exprs' <- mapM desugar exprs- return $ VectorExpr exprs'+desugar (VectorExpr exprs) =+ VectorExpr <$> mapM desugar exprs desugar (TensorExpr nsExpr xsExpr supExpr subExpr) = do nsExpr' <- desugar nsExpr@@ -221,20 +225,22 @@ TensorArg _ -> True _ -> False) (reverse names) case rhnames of- [] -> do expr' <- desugar expr- return $ LambdaExpr names expr'-+ [] -> LambdaExpr names <$> desugar expr (InvertedScalarArg rhname:rhnames') -> do let (rtnames2, rhnames2) = span (const False) rhnames' case rhnames2 of [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)- (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (FlipIndicesExpr (VarExpr $ stringToVar rhname)))+ (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (FlipIndicesExpr (stringToVarExpr rhname))) (ScalarArg rhname2:rhnames2') -> desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)- (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (VarExpr $ stringToVar rhname2) (FlipIndicesExpr (VarExpr $ stringToVar rhname)))+ (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr)+ (stringToVarExpr rhname2)+ (FlipIndicesExpr (stringToVarExpr rhname))) (InvertedScalarArg rhname2:rhnames2') -> desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)- (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (FlipIndicesExpr (VarExpr $ stringToVar rhname2)) (FlipIndicesExpr (VarExpr $ stringToVar rhname)))+ (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr)+ (FlipIndicesExpr (stringToVarExpr rhname2))+ (FlipIndicesExpr (stringToVarExpr rhname))) (ScalarArg rhname:rhnames') -> do let (rtnames2, rhnames2) = span (\case@@ -242,17 +248,16 @@ _ -> False) rhnames' case rhnames2 of [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)- (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (VarExpr $ stringToVar rhname))+ (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (stringToVarExpr rhname)) (ScalarArg rhname2:rhnames2') -> desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)- (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (VarExpr $ stringToVar rhname2) (VarExpr $ stringToVar rhname))+ (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (stringToVarExpr rhname2) (stringToVarExpr rhname)) (InvertedScalarArg rhname2:rhnames2') -> desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)- (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (FlipIndicesExpr (VarExpr $ stringToVar rhname2)) (VarExpr $ stringToVar rhname))+ (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (FlipIndicesExpr (stringToVarExpr rhname2)) (stringToVarExpr rhname)) -desugar (MemoizedLambdaExpr names expr) = do- expr' <- desugar expr- return $ MemoizedLambdaExpr names expr'+desugar (MemoizedLambdaExpr names expr) =+ MemoizedLambdaExpr names <$> desugar expr desugar (MemoizeExpr memoizeBindings expr) = do memoizeBindings' <- mapM (\(x,y,z) -> do x' <- desugar x@@ -263,164 +268,129 @@ expr' <- desugar expr return $ MemoizeExpr memoizeBindings' expr' -desugar (CambdaExpr name expr) = do- expr' <- desugar expr- return $ CambdaExpr name expr'+desugar (CambdaExpr name expr) =+ CambdaExpr name <$> desugar expr -desugar (ProcedureExpr names expr) = do- expr' <- desugar expr- return $ ProcedureExpr names expr'+desugar (ProcedureExpr names expr) =+ ProcedureExpr names <$> desugar expr -desugar (PatternFunctionExpr names pattern) = do- pattern' <- desugarPattern pattern- return $ PatternFunctionExpr names pattern'+desugar (PatternFunctionExpr names pattern) =+ PatternFunctionExpr names <$> desugarPattern pattern -desugar (IfExpr expr0 expr1 expr2) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- expr2' <- desugar expr2- return $ IfExpr expr0' expr1' expr2'+desugar (IfExpr expr0 expr1 expr2) =+ IfExpr <$> desugar expr0 <*> desugar expr1 <*> desugar expr2 -desugar (LetRecExpr binds expr) = do- binds' <- desugarBindings binds- expr' <- desugar expr- return $ LetRecExpr binds' expr'+desugar (LetRecExpr binds expr) =+ LetRecExpr <$> desugarBindings binds <*> desugar expr -desugar (LetExpr binds expr) = do- binds' <- desugarBindings binds- expr' <- desugar expr- return $ LetExpr binds' expr'+desugar (LetExpr binds expr) =+ LetExpr <$> desugarBindings binds <*> desugar expr desugar (LetStarExpr binds expr) = do binds' <- desugarBindings binds expr' <- desugar expr return $ foldr (\bind ret -> LetExpr [bind] ret) expr' binds' -desugar (WithSymbolsExpr vars expr) = do- expr' <- desugar expr- return $ WithSymbolsExpr vars expr'+desugar (WithSymbolsExpr vars expr) =+ WithSymbolsExpr vars <$> desugar expr -desugar (MatchExpr expr0 expr1 clauses) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- clauses' <- desugarMatchClauses clauses- return $ MatchExpr expr0' expr1' clauses'+desugar (MatchExpr expr0 expr1 clauses) =+ MatchExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses -desugar (MatchDFSExpr expr0 expr1 clauses) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- clauses' <- desugarMatchClauses clauses- return $ MatchDFSExpr expr0' expr1' clauses'+desugar (MatchDFSExpr expr0 expr1 clauses) =+ MatchDFSExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses -desugar (MatchAllExpr expr0 expr1 clauses) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- clauses' <- desugarMatchClauses clauses- return $ MatchAllExpr expr0' expr1' clauses'+desugar (MatchAllExpr expr0 expr1 clauses) =+ MatchAllExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses -desugar (MatchAllDFSExpr expr0 expr1 clauses) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- clauses' <- desugarMatchClauses clauses- return $ MatchAllDFSExpr expr0' expr1' clauses'+desugar (MatchAllDFSExpr expr0 expr1 clauses) =+ MatchAllDFSExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses -desugar (DoExpr binds expr) = do- binds' <- desugarBindings binds- expr' <- desugar expr- return $ DoExpr binds' expr'+desugar (DoExpr binds expr) =+ DoExpr <$> desugarBindings binds <*> desugar expr -desugar (IoExpr expr) = do- expr' <- desugar expr- return $ IoExpr expr'+desugar (IoExpr expr) =+ IoExpr <$> desugar expr -desugar (SeqExpr expr0 expr1) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- return $ SeqExpr expr0' expr1'+desugar (UnaryOpExpr "-" expr) =+ (\x -> makeApply "neg" [x]) <$> desugar expr+desugar (UnaryOpExpr "!" (ApplyExpr expr1 expr2)) =+ WedgeApplyExpr <$> desugar expr1 <*> desugar expr2+desugar (UnaryOpExpr "'" expr) = QuoteExpr <$> desugar expr+desugar (UnaryOpExpr "`" expr) = QuoteSymbolExpr <$> desugar expr +desugar (BinaryOpExpr op expr1 expr2) | isWedge op = do+ (\x y -> WedgeApplyExpr (stringToVarExpr (func op)) (TupleExpr [x, y]))+ <$> desugar expr1 <*> desugar expr2++desugar (BinaryOpExpr op expr1 expr2) =+ (\x y -> makeApply (func op) [x, y]) <$> desugar expr1 <*> desugar expr2++desugar (SeqExpr expr0 expr1) =+ SeqExpr <$> desugar expr0 <*> desugar expr1+ desugar (GenerateArrayExpr fnExpr (fstExpr, lstExpr)) = do fnExpr' <- desugar fnExpr fstExpr' <- desugar fstExpr lstExpr' <- desugar lstExpr return $ GenerateArrayExpr fnExpr' (fstExpr', lstExpr') -desugar (GenerateTensorExpr fnExpr sizeExpr) = do- fnExpr' <- desugar fnExpr- sizeExpr' <- desugar sizeExpr- return $ GenerateTensorExpr fnExpr' sizeExpr'+desugar (GenerateTensorExpr fnExpr sizeExpr) =+ GenerateTensorExpr <$> desugar fnExpr <*> desugar sizeExpr -desugar (TensorContractExpr fnExpr tExpr) = do- fnExpr' <- desugar fnExpr- tExpr' <- desugar tExpr- return $ TensorContractExpr fnExpr' tExpr'+desugar (TensorContractExpr fnExpr tExpr) =+ TensorContractExpr <$> desugar fnExpr <*> desugar tExpr -desugar (TensorMapExpr fnExpr tExpr) = do- fnExpr' <- desugar fnExpr- tExpr' <- desugar tExpr- return $ TensorMapExpr fnExpr' tExpr'+desugar (TensorMapExpr fnExpr tExpr) =+ TensorMapExpr <$> desugar fnExpr <*> desugar tExpr -desugar (TensorMap2Expr fnExpr t1Expr t2Expr) = do- fnExpr' <- desugar fnExpr- t1Expr' <- desugar t1Expr- t2Expr' <- desugar t2Expr- return $ TensorMap2Expr fnExpr' t1Expr' t2Expr'+desugar (TensorMap2Expr fnExpr t1Expr t2Expr) =+ TensorMap2Expr <$> desugar fnExpr <*> desugar t1Expr <*> desugar t2Expr -desugar (TransposeExpr vars expr) = do- vars' <- desugar vars- expr' <- desugar expr- return $ TransposeExpr vars' expr'+desugar (TransposeExpr vars expr) =+ TransposeExpr <$> desugar vars <*> desugar expr -desugar (FlipIndicesExpr expr) = do- expr' <- desugar expr- return $ FlipIndicesExpr expr'+desugar (FlipIndicesExpr expr) =+ FlipIndicesExpr <$> desugar expr -desugar (ApplyExpr expr0 expr1) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- return $ ApplyExpr expr0' expr1'+desugar (ApplyExpr expr0 expr1) =+ ApplyExpr <$> desugar expr0 <*> desugar expr1 -desugar (CApplyExpr expr0 expr1) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- return $ CApplyExpr expr0' expr1'+desugar (CApplyExpr expr0 expr1) =+ CApplyExpr <$> desugar expr0 <*> desugar expr1 desugar (VarExpr name) = asks $ fromMaybe (VarExpr name) . lookup (show name) desugar FreshVarExpr = do id <- fresh- return (VarExpr $ stringToVar (":::" ++ id))+ return $ stringToVarExpr (":::" ++ id) -desugar (MatcherExpr matcherInfo) = do- matcherInfo' <- desugarMatcherInfo matcherInfo- return $ MatcherExpr matcherInfo'+desugar (MatcherExpr matcherInfo) =+ MatcherExpr <$> desugarMatcherInfo matcherInfo desugar (PartialVarExpr n) = return $ PartialVarExpr n desugar (PartialExpr n expr) = do expr' <- desugar expr- return $ LetRecExpr [([stringToVar "::0"], PartialExpr n expr')] (VarExpr $ stringToVar "::0")+ return $ LetRecExpr [([stringToVar "::0"], PartialExpr n expr')] (stringToVarExpr "::0") -desugar (QuoteExpr expr) = do- expr' <- desugar expr- return $ QuoteExpr expr'+desugar (QuoteExpr expr) =+ QuoteExpr <$> desugar expr -desugar (QuoteSymbolExpr expr) = do- expr' <- desugar expr- return $ QuoteSymbolExpr expr'+desugar (QuoteSymbolExpr expr) =+ QuoteSymbolExpr <$> desugar expr -desugar (WedgeExpr (ApplyExpr expr0 expr1)) = do- expr0' <- desugar expr0- expr1' <- desugar expr1- return $ WedgeApplyExpr expr0' expr1'+desugar (WedgeExpr (ApplyExpr expr0 expr1)) =+ WedgeApplyExpr <$> desugar expr0 <*> desugar expr1 desugar expr = return expr desugarIndex :: Index EgisonExpr -> DesugarM (Index EgisonExpr)-desugarIndex (Superscript expr) = Superscript <$> desugar expr-desugarIndex (Subscript expr) = Subscript <$> desugar expr+desugarIndex (Superscript expr) = Superscript <$> desugar expr+desugarIndex (Subscript expr) = Subscript <$> desugar expr desugarIndex (SupSubscript expr) = SupSubscript <$> desugar expr-desugarIndex (Userscript expr) = Userscript <$> desugar expr+desugarIndex (Userscript expr) = Userscript <$> desugar expr desugarPattern :: EgisonPattern -> DesugarM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern@@ -485,10 +455,10 @@ lp:hps -> return $ InductivePat "mult" [intPat', foldr (\p r -> case p of- (PowerPat p1 p2) -> InductivePat "ncons" [p1, p2, r]+ PowerPat p1 p2 -> InductivePat "ncons" [p1, p2, r] _ -> InductivePat "cons" [p, r]) (case lp of- (PowerPat p1 p2) -> InductivePat "ncons" [p1, p2, ValuePat (IntegerExpr 1)]+ PowerPat p1 p2 -> InductivePat "ncons" [p1, p2, ValuePat (IntegerExpr 1)] _ -> lp) (reverse hps)] where@@ -498,49 +468,26 @@ desugarPattern' pattern = return pattern desugarLoopRange :: LoopRange -> DesugarM LoopRange-desugarLoopRange (LoopRange sExpr eExpr pattern) = do- sExpr' <- desugar sExpr- eExpr' <- desugar eExpr- pattern' <- desugarPattern' pattern- return $ LoopRange sExpr' eExpr' pattern'--desugarBinding :: BindingExpr -> DesugarM BindingExpr-desugarBinding (name, expr) = do- expr' <- desugar expr- return (name, expr')+desugarLoopRange (LoopRange sExpr eExpr pattern) =+ LoopRange <$> desugar sExpr <*> desugar eExpr <*> desugarPattern' pattern desugarBindings :: [BindingExpr] -> DesugarM [BindingExpr]-desugarBindings (bind:rest) = do- bind' <- desugarBinding bind- rest' <- desugarBindings rest- return $ bind' : rest'--desugarBindings [] = return []--desugarMatchClause :: MatchClause -> DesugarM MatchClause-desugarMatchClause (pattern, expr) = do- pattern' <- desugarPattern pattern- expr' <- desugar expr- return (pattern', expr')+desugarBindings = mapM f+ where f (name, expr) = (name,) <$> desugar expr desugarMatchClauses :: [MatchClause] -> DesugarM [MatchClause]-desugarMatchClauses (clause:rest) = do- clause' <- desugarMatchClause clause- rest' <- desugarMatchClauses rest- return $ clause' : rest'-desugarMatchClauses [] = return []+desugarMatchClauses = mapM f+ where f (pattern, expr) = (,) <$> desugarPattern pattern <*> desugar expr desugarMatcherInfo :: MatcherInfo -> DesugarM MatcherInfo-desugarMatcherInfo [] = return []-desugarMatcherInfo ((pp, matcher, pds):matcherInfo) = do- matcher' <- desugar matcher- pds' <- desugarPrimitiveDataMatchClauses pds- matcherInfo' <- desugarMatcherInfo matcherInfo- return $ (pp, matcher', pds'):matcherInfo'+desugarMatcherInfo = mapM f+ where+ f (pp, matcher, pds) =+ (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> DesugarM [(PrimitiveDataPattern, EgisonExpr)]-desugarPrimitiveDataMatchClauses [] = return []-desugarPrimitiveDataMatchClauses ((pd, expr):pds) = do- expr' <- desugar expr- pds' <- desugarPrimitiveDataMatchClauses pds- return $ (pd, expr'):pds'+desugarPrimitiveDataMatchClauses = mapM f+ where f (pd, expr) = (pd,) <$> desugar expr++makeApply :: String -> [EgisonExpr] -> EgisonExpr+makeApply func args = ApplyExpr (stringToVarExpr func) (TupleExpr args)
− hs-src/Language/Egison/Lexer.x
@@ -1,261 +0,0 @@-{-{-# OPTIONS -w #-}--{- |-Module : Language.Egison.Lexer-Copyright : Satoshi Egi-Licence : MIT--This module provides new Egison lexer.--}--module Language.Egison.Lexer- ( Token(..)- , AlexPosn(..)- , TokenClass(..)- , Alex(..)- , runAlex'- , alexMonadScan'- , alexError- , alexError'- ) where--import Prelude hiding (lex)-import Control.Monad (liftM)--import Language.Egison.Types--}--%wrapper "monadUserState"-$digit = 0-9-$alpha = [A-Za-z]-tokens :-- $white+ ;-- -- Keywords- True { lex' TokenTrue }- False { lex' TokenFalse }- test { lex' TokenTest }- match { lex' TokenMatch }- matchDFS { lex' TokenMatchDFS }- matchAll { lex' TokenMatchAll }- matchAllDFS { lex' TokenMatchAllDFS }- matchLambda { lex' TokenMatchLambda }- matchAllLambda { lex' TokenMatchAllLambda }- as { lex' TokenAs }- with { lex' TokenWith }- something { lex' TokenSomething }- if { lex' TokenIf }- then { lex' TokenThen }- else { lex' TokenElse }-- -- Data- $digit+ { lex (TokenInt . read) }- $alpha [$alpha $digit \']* { lex TokenVar }-- -- Operators- \=\= { lex' TokenEqEq }- \< { lex' TokenLT }- \> { lex' TokenGT }- \<\= { lex' TokenLE }- \>\= { lex' TokenGE }- \+ { lex' TokenPlus }- \- { lex' TokenMinus }- \% { lex' TokenPercent }- \* { lex' TokenAsterisk }- \/ { lex' TokenDiv }- \^ { lex' TokenCaret }- \&\& { lex' TokenAndAnd }- \|\| { lex' TokenBarBar }- \: { lex' TokenColon }- \.\. { lex' TokenDotDot }- \+\+ { lex' TokenPlusPlus }-- \| { lex' TokenBar }- \-\> { lex' TokenArrow }- \$ { lex' TokenDollar }- \_ { lex' TokenUnderscore }- \# { lex' TokenSharp }- \, { lex' TokenComma }- \\ { lex' TokenBackSlash }- \*\$ { lex' TokenAstDollar }- \= { lex' TokenEq }-- \( { lex' TokenLParen }- \) { lex' TokenRParen }- \[ { lex' TokenLBracket }- \] { lex' TokenRBracket }--{--- To improve error messages, We keep the path of the file we are--- lexing in our own state.-data AlexUserState = AlexUserState { filePath :: FilePath }--alexInitUserState :: AlexUserState-alexInitUserState = AlexUserState "<unknown>"--getFilePath :: Alex FilePath-getFilePath = liftM filePath alexGetUserState--setFilePath :: FilePath -> Alex ()-setFilePath = alexSetUserState . AlexUserState---- The token type, consisting of the source code position and a token class.-data Token = Token AlexPosn TokenClass- deriving ( Show )--data TokenClass- -- Keywords- = TokenTrue- | TokenFalse- | TokenTest- | TokenMatch- | TokenMatchDFS- | TokenMatchAll- | TokenMatchAllDFS- | TokenMatchLambda- | TokenMatchAllLambda- | TokenAs- | TokenWith- | TokenSomething- | TokenIf- | TokenThen- | TokenElse-- -- Data and Variables- | TokenInt Integer- | TokenVar String-- | TokenEqEq- | TokenLT- | TokenGT- | TokenLE- | TokenGE- | TokenPlus- | TokenMinus- | TokenPercent- | TokenAsterisk- | TokenDiv- | TokenCaret- | TokenAndAnd- | TokenBarBar- | TokenColon- | TokenDotDot- | TokenPlusPlus-- | TokenBar- | TokenArrow- | TokenDollar- | TokenUnderscore- | TokenSharp- | TokenComma- | TokenBackSlash- | TokenAstDollar- | TokenEq-- | TokenLParen- | TokenRParen- | TokenLBracket- | TokenRBracket- | TokenEOF---- For nice parser error messages.-instance Show TokenClass where- show TokenTrue = "True"- show TokenFalse = "False"- show TokenTest = "test"- show TokenMatch = "match"- show TokenMatchDFS = "matchDFS"- show TokenMatchAll = "matchAll"- show TokenMatchAllDFS = "matchAllDFS"- show TokenMatchLambda = "matchLambda"- show TokenMatchAllLambda = "matchAllLambda"- show TokenAs = "as"- show TokenWith = "with"- show TokenSomething = "something"- show TokenIf = "if"- show TokenThen = "then"- show TokenElse = "else"-- show (TokenInt i) = show i- show (TokenVar s) = show s-- show TokenEqEq = "=="- show TokenLT = "<"- show TokenGT = ">"- show TokenLE = "<="- show TokenGE = ">="- show TokenPlus = "+"- show TokenMinus = "-"- show TokenPercent = "%"- show TokenAsterisk = "*"- show TokenDiv = "/"- show TokenCaret = "^"- show TokenAndAnd = "&&"- show TokenBarBar = "||"- show TokenColon = ":"- show TokenDotDot = ".."- show TokenPlusPlus = "++"-- show TokenBar = "|"- show TokenArrow = "->"- show TokenDollar = "$"- show TokenUnderscore = "_"- show TokenSharp = "#"- show TokenComma = ","- show TokenBackSlash = "\\"- show TokenAstDollar = "*$"- show TokenEq = "="-- show TokenLParen = "("- show TokenRParen = ")"- show TokenLBracket = "["- show TokenRBracket = "]"- show TokenEOF = "<EOF>"--alexEOF :: Alex Token-alexEOF = do- (p,_,_,_) <- alexGetInput- return $ Token p TokenEOF---- Unfortunately, we have to extract the matching bit of string--- ourselves...-lex :: (String -> TokenClass) -> AlexAction Token-lex f = \(p,_,_,s) i -> return $ Token p (f (take i s))---- For constructing tokens that do not depend on--- the input-lex' :: TokenClass -> AlexAction Token-lex' = lex . const---- We rewrite alexMonadScan' to delegate to alexError' when lexing fails--- (the default implementation just returns an error message).-alexMonadScan' :: Alex Token-alexMonadScan' = do- inp <- alexGetInput- sc <- alexGetStartCode- case alexScan inp sc of- AlexEOF -> alexEOF- AlexError (p, _, _, s) ->- alexError' p ("lexical error at character '" ++ take 1 s ++ "'")- AlexSkip inp' len -> do- alexSetInput inp'- alexMonadScan'- AlexToken inp' len action -> do- alexSetInput inp'- action (ignorePendingBytes inp) len---- Signal an error, including a commonly accepted source code position.-alexError' :: AlexPosn -> String -> Alex a-alexError' (AlexPn _ l c) msg = do- fp <- getFilePath- alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)---- A variant of runAlex, keeping track of the path of the file we are lexing.-runAlex' :: Alex a -> String -> Either EgisonError a-runAlex' a input =- case runAlex input (setFilePath "<stdin>" >> a) of- Left msg -> Left $ Parser msg- Right r -> Right r-}
hs-src/Language/Egison/MathOutput.hs view
@@ -8,10 +8,7 @@ module Language.Egison.MathOutput ( changeOutputInLang ) where -import Control.Monad-import System.Environment import Text.ParserCombinators.Parsec hiding (spaces)- changeOutputInLang :: String -> String -> String changeOutputInLang "haskell" input = mathExprToHaskell input
hs-src/Language/Egison/Parser.hs view
@@ -26,9 +26,8 @@ ) where import Control.Applicative (pure, (*>), (<$>), (<*), (<*>))-import Control.Monad.Except hiding (mapM)-import Control.Monad.Identity hiding (mapM)-import Control.Monad.State hiding (mapM)+import Control.Monad.Except (liftIO, throwError)+import Control.Monad.Identity (Identity, unless) import Prelude hiding (mapM) import System.Directory (doesFileExist, getHomeDirectory)@@ -38,7 +37,6 @@ import Data.Functor (($>)) import Data.List.Split (splitOn) import Data.Ratio-import qualified Data.Sequence as Sq import qualified Data.Set as Set import Data.Traversable (mapM) @@ -47,7 +45,6 @@ import qualified Text.Parsec.Token as P import qualified Data.Text as T-import Text.Regex.TDFA import Language.Egison.Desugar import Language.Egison.Types@@ -169,9 +166,6 @@ loadExpr :: Parser EgisonTopExpr loadExpr = keywordLoad >> Load <$> stringLiteral -exprs :: Parser [EgisonExpr]-exprs = endBy expr whiteSpace- expr :: Parser EgisonExpr expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr' expr1 <- option expr0 $ try (string "..." >> IndexedExpr False expr0 <$> parseindex)@@ -312,10 +306,10 @@ quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr matchAllExpr :: Parser EgisonExpr-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses)+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses) matchAllDFSExpr :: Parser EgisonExpr-matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses)+matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses) matchExpr :: Parser EgisonExpr matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses@@ -324,7 +318,7 @@ matchDFSExpr = keywordMatchDFS >> MatchDFSExpr <$> expr <*> expr <*> matchClauses matchAllLambdaExpr :: Parser EgisonExpr-matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses)+matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((:[]) <$> matchClause) <|> matchClauses) matchLambdaExpr :: Parser EgisonExpr matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses@@ -430,7 +424,7 @@ withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident whiteSpace) <*> expr doExpr :: Parser EgisonExpr-doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr $ stringToVar "return") (TupleExpr [])) expr+doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (stringToVarExpr "return") (TupleExpr [])) expr statements :: Parser [BindingExpr] statements = braces $ sepEndBy statement whiteSpace@@ -660,7 +654,7 @@ loopRange = brackets (try (LoopRange <$> expr <*> expr <*> option WildCard pattern) <|> (do s <- expr ep <- option WildCard pattern- return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, IntegerExpr 1]))) ep)))+ return (LoopRange s (ApplyExpr (stringToVarExpr "from") (ApplyExpr (stringToVarExpr "-'") (TupleExpr [s, IntegerExpr 1]))) ep))) seqNilPat :: Parser EgisonPattern seqNilPat = braces $ pure SeqNilPat@@ -672,7 +666,7 @@ seqPat = braces $ do pats <- sepEndBy pattern whiteSpace tailPat <- option SeqNilPat (char '@' >> pattern)- return $ foldr (\p rets -> SeqConsPat p rets) tailPat pats+ return $ foldr SeqConsPat tailPat pats laterPatVar :: Parser EgisonPattern laterPatVar = char '#' >> pure LaterPatVar@@ -713,9 +707,9 @@ floatExpr :: Parser EgisonExpr floatExpr = do- (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i')- <|> try ((,) 0 <$> floatLiteral' <* char 'i')- <|> try ((, 0) <$> floatLiteral')+ (x,y) <- try ((,) <$> floatLiteral <*> (sign' <*> positiveFloatLiteral) <* char 'i')+ <|> try ((0,) <$> floatLiteral <* char 'i')+ <|> try ((, 0) <$> floatLiteral) return $ FloatExpr x y integerExpr :: Parser EgisonExpr@@ -736,8 +730,8 @@ let l = m % (10 ^ fromIntegral (length mStr)) return (fromRational (fromIntegral n + l) :: Double) -floatLiteral' :: Parser Double-floatLiteral' = sign <*> positiveFloatLiteral+floatLiteral :: Parser Double+floatLiteral = sign <*> positiveFloatLiteral -- -- Tokens@@ -851,8 +845,6 @@ keywordLoadFile = reserved "load-file" keywordLoad = reserved "load" keywordIf = reserved "if"-keywordThen = reserved "then"-keywordElse = reserved "else" keywordNot = reserved "not" keywordAnd = reserved "and" keywordOr = reserved "or"@@ -912,14 +904,8 @@ sign' = (char '-' >> return negate) <|> (char '+' >> return id) -naturalLiteral :: Parser Integer-naturalLiteral = P.natural lexer- integerLiteral :: Parser Integer integerLiteral = sign <*> P.natural lexer--floatLiteral :: Parser Double-floatLiteral = sign <*> P.float lexer stringLiteral :: Parser String stringLiteral = P.stringLiteral lexer
hs-src/Language/Egison/ParserNonS.hs view
@@ -26,9 +26,8 @@ ) where import Control.Applicative (pure, (*>), (<$>), (<*), (<*>))-import Control.Monad.Except hiding (mapM)-import Control.Monad.Identity hiding (mapM)-import Control.Monad.State hiding (mapM)+import Control.Monad.Except (liftIO, throwError)+import Control.Monad.Identity (Identity, unless) import Prelude hiding (mapM) import System.Directory (doesFileExist, getHomeDirectory)@@ -39,8 +38,6 @@ import Data.List (intercalate) import Data.List.Split (split, splitOn, startsWithOneOf) import Data.Ratio-import qualified Data.Sequence as Sq-import qualified Data.Set as Set import Data.Traversable (mapM) import Text.Parsec@@ -49,7 +46,6 @@ import qualified Text.Parsec.Token as P import qualified Data.Text as T-import Text.Regex.TDFA import Language.Egison.Desugar import Language.Egison.Types@@ -171,9 +167,6 @@ loadExpr :: Parser EgisonTopExpr loadExpr = keywordLoad >> Load <$> parens stringLiteral -exprs :: Parser [EgisonExpr]-exprs = endBy expr whiteSpace- expr :: Parser EgisonExpr expr = (try applyInfixExpr <|> try exprWithSymbol@@ -195,12 +188,12 @@ , [binary "&&" "and" AssocLeft, binary "||" "or" AssocLeft] , [binary "++" "join" AssocRight] ]- unary "-" assoc = Prefix (try $ inSpaces (string "-") >> return (\x -> makeApply (VarExpr $ stringToVar "*") [IntegerExpr (-1), x]))- unary op assoc = Prefix (try $ inSpaces (string op) >> return (\x -> makeApply (VarExpr $ stringToVar op) [x]))+ unary "-" assoc = Prefix (try $ inSpaces (string "-") >> return (\x -> makeApply (stringToVarExpr "*") [IntegerExpr (-1), x]))+ unary op assoc = Prefix (try $ inSpaces (string op) >> return (\x -> makeApply (stringToVarExpr op) [x])) binary op name assoc- | op == "/" = Infix (try $ (try (inSpaces1 $ string op) <|> (inSpaces (string op) >> notFollowedBy (string "m" <|> string "fn"))) >> return (\x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc- | op == "." || op == "%" = Infix (try $ inSpaces1 (string op) >> return (\x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc- | otherwise = Infix (try $ inSpaces (string op) >> return (\x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc+ | op == "/" = Infix (try $ (try (inSpaces1 $ string op) <|> (inSpaces (string op) >> notFollowedBy (string "m" <|> string "fn"))) >> return (\x y -> makeApply (stringToVarExpr name) [x, y])) assoc+ | op == "." || op == "%" = Infix (try $ inSpaces1 (string op) >> return (\x y -> makeApply (stringToVarExpr name) [x, y])) assoc+ | otherwise = Infix (try $ inSpaces (string op) >> return (\x y -> makeApply (stringToVarExpr name) [x, y])) assoc inSpaces :: Parser a -> Parser () inSpaces p = skipMany (space <|> newline) >> p >> skipMany (space <|> newline)@@ -209,9 +202,9 @@ inSpaces1 p = skipMany (space <|> newline) >> p >> skipMany1 (space <|> newline) exprWithSymbol :: Parser EgisonExpr-exprWithSymbol = (string "d/d" >> applyExpr'' (VarExpr $ stringToVar "d/d"))- <|> (string "V.*" >> applyExpr'' (VarExpr $ stringToVar "V.*"))- <|> (string "M.*" >> applyExpr'' (VarExpr $ stringToVar "M.*"))+exprWithSymbol = (string "d/d" >> applyExpr'' (stringToVarExpr "d/d"))+ <|> (string "V.*" >> applyExpr'' (stringToVarExpr "V.*"))+ <|> (string "M.*" >> applyExpr'' (stringToVarExpr "M.*")) <|> (lookAhead (string "let*") >> letStarExpr) term :: Parser EgisonExpr@@ -429,7 +422,7 @@ withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident comma) <*> expr doExpr :: Parser EgisonExpr-doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr $ stringToVar "return") (TupleExpr [])) expr+doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (stringToVarExpr "return") (TupleExpr [])) expr statements :: Parser [BindingExpr] statements = braces $ sepEndBy statement comma@@ -514,7 +507,7 @@ args''' = map (VarExpr . stringToVar . either id id) args'' in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args' | all (not . null) vars ->- let n = Set.size $ Set.fromList vars+ let n = length vars args' = rights args args'' = zipWith (curry g) args (annonVars (n + 1) (length args)) args''' = map (VarExpr . stringToVar . either id id) args''@@ -657,7 +650,7 @@ <|> (do s <- expr comma ep <- option WildCard pattern- return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, IntegerExpr 1]))) ep)))+ return (LoopRange s (ApplyExpr (stringToVarExpr "from") (ApplyExpr (stringToVarExpr "-'") (TupleExpr [s, IntegerExpr 1]))) ep))) -- Constants @@ -682,9 +675,9 @@ floatExpr :: Parser EgisonExpr floatExpr = do- (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i')- <|> try ((,) 0 <$> floatLiteral' <* char 'i')- <|> try ((, 0) <$> floatLiteral')+ (x,y) <- try ((,) <$> floatLiteral <*> (sign' <*> positiveFloatLiteral) <* char 'i')+ <|> try ((,) 0 <$> floatLiteral <* char 'i')+ <|> try ((, 0) <$> floatLiteral) return $ FloatExpr x y integerExpr :: Parser EgisonExpr@@ -705,8 +698,8 @@ let l = m % (10 ^ fromIntegral (length mStr)) return (fromRational (fromIntegral n + l) :: Double) -floatLiteral' :: Parser Double-floatLiteral' = sign <*> positiveFloatLiteral+floatLiteral :: Parser Double+floatLiteral = sign <*> positiveFloatLiteral -- -- Tokens@@ -864,14 +857,8 @@ sign' = (char '-' >> return negate) <|> (char '+' >> return id) -naturalLiteral :: Parser Integer-naturalLiteral = P.natural lexer- integerLiteral :: Parser Integer integerLiteral = sign <*> P.natural lexer--floatLiteral :: Parser Double-floatLiteral = sign <*> P.float lexer stringLiteral :: Parser String stringLiteral = P.stringLiteral lexer
+ hs-src/Language/Egison/ParserNonS2.hs view
@@ -0,0 +1,783 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiWayIf #-}++{- |+Module : Language.Egison.ParserNonS2+Copyright : Satoshi Egi+Licence : MIT++This module provide Egison parser.+-}++module Language.Egison.ParserNonS2+ (+ -- * Parse a string+ readTopExprs+ , readTopExpr+ , readExprs+ , readExpr+ , parseTopExprs+ , parseTopExpr+ , parseExprs+ , parseExpr+ -- * Parse a file+ , loadLibraryFile+ , loadFile+ ) where++import Control.Applicative (pure, (*>), (<$>), (<$), (<*), (<*>))+import Control.Monad.Except (liftIO, throwError)+import Control.Monad.State (unless)+import Prelude hiding (mapM)++import System.Directory (doesFileExist, getHomeDirectory)++import Data.Functor (($>))+import Data.List (find)+import Data.Maybe (fromJust, isJust)+import Data.Traversable (mapM)++import Control.Monad.Combinators.Expr+import Data.Void+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec.Debug (dbg)+import Text.Megaparsec.Pos (Pos)++import Data.Text (pack)++import Language.Egison.Desugar+import Language.Egison.Types+import Paths_egison (getDataFileName)++readTopExprs :: String -> EgisonM [EgisonTopExpr]+readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs++readTopExpr :: String -> EgisonM EgisonTopExpr+readTopExpr = either throwError desugarTopExpr . parseTopExpr++readExprs :: String -> EgisonM [EgisonExpr]+readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs++readExpr :: String -> EgisonM EgisonExpr+readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr++parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]+parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof++parseTopExpr :: String -> Either EgisonError EgisonTopExpr+parseTopExpr = doParse $ sc >> topExpr++parseExprs :: String -> Either EgisonError [EgisonExpr]+parseExprs = doParse $ many (L.nonIndented sc expr) <* eof++parseExpr :: String -> Either EgisonError EgisonExpr+parseExpr = doParse $ sc >> expr++-- |Load a libary file+loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]+loadLibraryFile file = do+ homeDir <- liftIO getHomeDirectory+ doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file+ if doesExist+ then loadFile $ homeDir ++ "/.egison/" ++ file+ else liftIO (getDataFileName file) >>= loadFile++-- |Load a file+loadFile :: FilePath -> EgisonM [EgisonTopExpr]+loadFile file = do+ doesExist <- liftIO $ doesFileExist file+ unless doesExist $ throwError $ Default ("file does not exist: " ++ file)+ input <- liftIO $ readUTF8File file+ exprs <- readTopExprs $ shebang input+ concat <$> mapM recursiveLoad exprs+ where+ recursiveLoad (Load file) = loadLibraryFile file+ recursiveLoad (LoadFile file) = loadFile file+ recursiveLoad expr = return [expr]+ shebang :: String -> String+ shebang ('#':'!':cs) = ';':'#':'!':cs+ shebang cs = cs++--+-- Parser+--++type Parser = Parsec CustomError String++data CustomError+ = IllFormedPointFreeExpr EgisonBinOp EgisonBinOp+ deriving (Eq, Ord)++instance ShowErrorComponent CustomError where+ showErrorComponent (IllFormedPointFreeExpr op op') =+ "The operator " ++ info op ++ " must have lower precedence than " ++ info op'+ where+ info op =+ "'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]"+++doParse :: Parser a -> String -> Either EgisonError a+doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input+ where+ fromParsecError :: ParseErrorBundle String CustomError -> EgisonError+ fromParsecError = Parser . errorBundlePretty++--+-- Expressions+--++topExpr :: Parser EgisonTopExpr+topExpr = Load <$> (keywordLoad >> stringLiteral)+ <|> LoadFile <$> (keywordLoadFile >> stringLiteral)+ <|> defineOrTestExpr+ <?> "toplevel expression"++defineOrTestExpr :: Parser EgisonTopExpr+defineOrTestExpr = do+ e <- expr+ (do symbol "="+ body <- expr+ return (convertToDefine e body))+ <|> return (Test e)+ where+ convertToDefine :: EgisonExpr -> EgisonExpr -> EgisonTopExpr+ convertToDefine (VarExpr var) body = Define var body+ convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) body =+ Define var (LambdaExpr (map exprToArg args) body)++ -- TODO(momohatt): Handle other types of arg+ exprToArg :: EgisonExpr -> Arg+ exprToArg (VarExpr (Var [x] [])) = ScalarArg x++expr :: Parser EgisonExpr+expr = ifExpr+ <|> patternMatchExpr+ <|> lambdaExpr+ <|> letExpr+ <|> withSymbolsExpr+ <|> doExpr+ <|> matcherExpr+ <|> algebraicDataMatcherExpr+ <|> memoizedLambdaExpr+ <|> procedureExpr+ <|> macroExpr+ <|> generateTensorExpr+ <|> tensorExpr+ <|> functionExpr+ <|> opExpr+ <?> "expression"++-- Also parses atomExpr+opExpr :: Parser EgisonExpr+opExpr = do+ pos <- L.indentLevel+ makeExprParser atomOrApplyExpr (makeTable pos)+ where+ makeTable :: Pos -> [[Operator Parser EgisonExpr]]+ makeTable pos =+ let unary sym = UnaryOpExpr <$> operator sym+ binary sym = do+ op <- try (L.indentGuard sc GT pos >> binOpLiteral sym <* notFollowedBy (symbol ")"))+ return $ BinaryOpExpr op+ in+ [ [ Prefix (unary "-" )+ , Prefix (unary "!" ) ]+ -- 8+ , [ InfixL (binary "^" ) ]+ -- 7+ , [ InfixL (binary "*" )+ , InfixL (binary "/" )+ , InfixL (binary "%" ) ]+ -- 6+ , [ InfixL (binary "+" )+ , InfixL (binary "-" ) ]+ -- 5+ , [ InfixR (binary ":" )+ , InfixR (binary "++") ]+ -- 4+ , [ InfixL (binary "==")+ , InfixL (binary "<=")+ , InfixL (binary "<" )+ , InfixL (binary ">=")+ , InfixL (binary ">" ) ]+ -- 3+ , [ InfixR (binary "&&") ]+ -- 2+ , [ InfixR (binary "||") ]+ ]++ifExpr :: Parser EgisonExpr+ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr++patternMatchExpr :: Parser EgisonExpr+patternMatchExpr = makeMatchExpr keywordMatch MatchExpr+ <|> makeMatchExpr keywordMatchDFS MatchDFSExpr+ <|> makeMatchExpr keywordMatchAll MatchAllExpr+ <|> makeMatchExpr keywordMatchAllDFS MatchAllDFSExpr+ <?> "pattern match expression"+ where+ makeMatchExpr keyword ctor = do+ tgt <- keyword >> expr+ matcher <- keywordAs >> expr <* keywordWith+ clauses <- matchClauses1+ return $ ctor tgt matcher clauses++-- Parse more than 1 match clauses.+-- TODO(momohatt): Require first bar '|' when there are multiple match clauses+matchClauses1 :: Parser [MatchClause]+matchClauses1 = do+ pos <- optional (symbol "|") >> L.indentLevel+ (:) <$> matchClause pos <*> matchClauses pos+ where+ matchClauses :: Pos -> Parser [MatchClause]+ matchClauses pos = try ((:) <$> (symbol "|" >> matchClause pos) <*> matchClauses pos)+ <|> return []+ matchClause :: Pos -> Parser MatchClause+ matchClause pos = (,) <$> (L.indentGuard sc EQ pos *> pattern) <*> (symbol "->" >> expr)++lambdaExpr :: Parser EgisonExpr+lambdaExpr = symbol "\\" >> (+ makeMatchLambdaExpr keywordMatch MatchLambdaExpr+ <|> makeMatchLambdaExpr keywordMatchAll MatchAllLambdaExpr+ <|> try (LambdaExpr <$> some arg <*> (symbol "->" >> expr))+ <|> PatternFunctionExpr <$> some lowerId <*> (symbol "=>" >> pattern))+ <?> "lambda or pattern function expression"+ where+ makeMatchLambdaExpr keyword ctor = do+ matcher <- keyword >> keywordAs >> expr+ clauses <- keywordWith >> matchClauses1+ return $ ctor matcher clauses++arg :: Parser Arg+arg = InvertedScalarArg <$> (symbol "*$" >> lowerId)+ <|> TensorArg <$> (symbol "%" >> lowerId)+ <|> ScalarArg <$> lowerId+ <?> "argument"++letExpr :: Parser EgisonExpr+letExpr = do+ pos <- keywordLet >> L.indentLevel+ binds <- some (L.indentGuard sc EQ pos *> binding)+ body <- keywordIn >> expr+ return $ LetRecExpr binds body++binding :: Parser BindingExpr+binding = do+ (vars, args) <- (,[]) <$> parens (sepBy varLiteral comma)+ <|> do var <- varLiteral+ args <- many arg+ return ([var], args)+ body <- symbol "=" >> expr+ return $ case args of+ [] -> (vars, body)+ _ -> (vars, LambdaExpr args body)++withSymbolsExpr :: Parser EgisonExpr+withSymbolsExpr = WithSymbolsExpr <$> (keywordWithSymbols >> brackets (sepBy lowerId comma)) <*> expr++doExpr :: Parser EgisonExpr+doExpr = do+ pos <- keywordDo >> L.indentLevel+ stmts <- some $ L.indentGuard sc EQ pos >> statement+ ret <- option (makeApply' "return" []) $ L.indentGuard sc EQ pos >> expr+ return $ DoExpr stmts ret+ where+ statement :: Parser BindingExpr+ statement = (keywordLet >> binding) <|> ([],) <$> expr++matcherExpr :: Parser EgisonExpr+matcherExpr = do+ keywordMatcher+ pos <- L.indentLevel+ -- In matcher expression, the first '|' (bar) is indispensable+ info <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)+ return $ MatcherExpr info+ where+ patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+ patternDef = do+ pp <- ppPattern+ returnMatcher <- keywordAs >> expr <* keywordWith+ pos <- L.indentLevel+ datapat <- some (L.indentGuard sc EQ pos >> symbol "|" >> dataCases)+ return (pp, returnMatcher, datapat)++ dataCases :: Parser (PrimitiveDataPattern, EgisonExpr)+ dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr)++algebraicDataMatcherExpr :: Parser EgisonExpr+algebraicDataMatcherExpr = do+ keywordAlgebraicDataMatcher+ pos <- L.indentLevel+ defs <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)+ return $ AlgebraicDataMatcherExpr defs+ where+ patternDef :: Parser (String, [EgisonExpr])+ patternDef = do+ pos <- L.indentLevel+ patternCtor <- lowerId+ args <- many (L.indentGuard sc GT pos >> atomExpr)+ return (patternCtor, args)++memoizedLambdaExpr :: Parser EgisonExpr+memoizedLambdaExpr = MemoizedLambdaExpr <$> (keywordMemoizedLambda >> many lowerId) <*> (symbol "->" >> expr)++procedureExpr :: Parser EgisonExpr+procedureExpr = ProcedureExpr <$> (keywordProcedure >> many lowerId) <*> (symbol "->" >> expr)++macroExpr :: Parser EgisonExpr+macroExpr = MacroExpr <$> (keywordMacro >> many lowerId) <*> (symbol "->" >> expr)++generateTensorExpr :: Parser EgisonExpr+generateTensorExpr = GenerateTensorExpr <$> (keywordGenerateTensor >> atomExpr) <*> atomExpr++tensorExpr :: Parser EgisonExpr+tensorExpr = TensorExpr <$> (keywordTensor >> atomExpr) <*> atomExpr+ <*> option (CollectionExpr []) atomExpr+ <*> option (CollectionExpr []) atomExpr++functionExpr :: Parser EgisonExpr+functionExpr = FunctionExpr <$> (keywordFunction >> parens (sepBy expr comma))++collectionExpr :: Parser EgisonExpr+collectionExpr = symbol "[" >> (try betweenOrFromExpr <|> elementsExpr)+ where+ betweenOrFromExpr = do+ start <- expr <* symbol ".."+ end <- optional expr <* symbol "]"+ case end of+ Just end' -> return $ makeApply' "between" [start, end']+ Nothing -> return $ makeApply' "from" [start]++ elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> expr) comma <* symbol "]")++tupleOrParenExpr :: Parser EgisonExpr+tupleOrParenExpr = do+ elems <- symbol "(" >> try (sepBy expr comma <* symbol ")") <|> (pointFreeExpr <* symbol ")")+ case elems of+ [x] -> return x+ _ -> return $ TupleExpr elems+ where+ pointFreeExpr :: Parser [EgisonExpr]+ pointFreeExpr =+ (do op <- try . choice $ map (binOpLiteral . repr) reservedBinops+ rarg <- optional expr+ case rarg of+ Just (BinaryOpExpr op' _ _) | priority op >= priority op' ->+ customFailure (IllFormedPointFreeExpr op op')+ _ -> return [makeLambda op Nothing rarg])+ <|> (do larg <- opExpr+ op <- choice $ map (binOpLiteral . repr) reservedBinops+ case larg of+ BinaryOpExpr op' _ _ | priority op >= priority op' ->+ customFailure (IllFormedPointFreeExpr op op')+ _ -> return [makeLambda op (Just larg) Nothing])++ makeLambda :: EgisonBinOp -> Maybe EgisonExpr -> Maybe EgisonExpr -> EgisonExpr+ makeLambda op Nothing Nothing =+ LambdaExpr [ScalarArg ":x", ScalarArg ":y"]+ (BinaryOpExpr op (stringToVarExpr ":x") (stringToVarExpr ":y"))+ makeLambda op Nothing (Just rarg) =+ LambdaExpr [ScalarArg ":x"] (BinaryOpExpr op (stringToVarExpr ":x") rarg)+ makeLambda op (Just larg) Nothing =+ LambdaExpr [ScalarArg ":y"] (BinaryOpExpr op larg (stringToVarExpr ":y"))++arrayExpr :: Parser EgisonExpr+arrayExpr = ArrayExpr <$> between (symbol "(|") (symbol "|)") (sepEndBy expr comma)++vectorExpr :: Parser EgisonExpr+vectorExpr = VectorExpr <$> between (symbol "[|") (symbol "|]") (sepEndBy expr comma)++hashExpr :: Parser EgisonExpr+hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma)+ where+ hashBraces = between (symbol "{|") (symbol "|}")+ hashElem = brackets $ (,) <$> expr <*> (comma >> expr)++index :: Parser (Index EgisonExpr)+index = SupSubscript <$> (string "~_" >> atomExpr')+ <|> try (char '_' >> subscript)+ <|> try (char '~' >> superscript)+ <|> try (Userscript <$> (char '|' >> atomExpr'))+ <?> "index"+ where+ subscript = do+ e1 <- atomExpr'+ e2 <- optional (string "..._" >> atomExpr')+ case e2 of+ Nothing -> return $ Subscript e1+ Just e2' -> return $ MultiSubscript e1 e2'+ superscript = do+ e1 <- atomExpr'+ e2 <- optional (string "...~" >> atomExpr')+ case e2 of+ Nothing -> return $ Superscript e1+ Just e2' -> return $ MultiSuperscript e1 e2'++atomOrApplyExpr :: Parser EgisonExpr+atomOrApplyExpr = do+ pos <- L.indentLevel+ func <- atomExpr+ args <- many (L.indentGuard sc GT pos *> atomExpr)+ return $ case args of+ [] -> func+ _ -> makeApply func args++atomExpr :: Parser EgisonExpr+atomExpr = do+ e <- atomExpr'+ -- TODO(momohatt): "..." (override of index) collides with ContPat+ indices <- many index+ return $ case indices of+ [] -> e+ _ -> IndexedExpr False e indices++-- atom expr without index+atomExpr' :: Parser EgisonExpr+atomExpr' = constantExpr+ <|> VarExpr <$> varLiteral+ <|> (\x -> InductiveDataExpr x []) <$> upperId+ <|> vectorExpr -- must come before collectionExpr+ <|> arrayExpr -- must come before tupleOrParenExpr+ <|> collectionExpr+ <|> tupleOrParenExpr+ <|> hashExpr+ <|> QuoteExpr <$> (char '\'' >> atomExpr')+ <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')+ <?> "atomic expression"++constantExpr :: Parser EgisonExpr+constantExpr = numericExpr+ <|> BoolExpr <$> boolLiteral+ <|> CharExpr <$> try charLiteral -- try for quoteExpr+ <|> StringExpr . pack <$> stringLiteral+ <|> SomethingExpr <$ keywordSomething+ <|> UndefinedExpr <$ keywordUndefined++numericExpr :: Parser EgisonExpr+numericExpr = try (uncurry FloatExpr <$> floatLiteral)+ <|> IntegerExpr <$> positiveIntegerLiteral+ <?> "numeric expression"+--+-- Pattern+--++pattern :: Parser EgisonPattern+pattern = letPattern+ <|> loopPattern+ <|> opPattern+ <?> "pattern"++letPattern :: Parser EgisonPattern+letPattern = do+ pos <- keywordLet >> L.indentLevel+ binds <- some (L.indentGuard sc EQ pos *> binding)+ body <- keywordIn >> pattern+ return $ LetPat binds body++loopPattern :: Parser EgisonPattern+loopPattern = do+ keywordLoop+ iter <- patVarLiteral+ range <- loopRange+ loopBody <- optional (symbol "|") >> pattern+ loopEnd <- symbol "|" >> pattern+ return $ LoopPat iter range loopBody loopEnd+ where+ loopRange :: Parser LoopRange+ loopRange =+ parens $ do start <- expr+ ends <- option (defaultEnds start) (try $ comma >> expr)+ as <- option WildCard (comma >> pattern)+ return $ LoopRange start ends as++ defaultEnds s =+ ApplyExpr (stringToVarExpr "from")+ (makeApply (stringToVarExpr "-'") [s, IntegerExpr 1])++seqPattern :: Parser EgisonPattern+seqPattern = do+ pats <- braces $ sepBy pattern comma+ return $ foldr SeqConsPat SeqNilPat pats++opPattern :: Parser EgisonPattern+opPattern = makeExprParser applyOrAtomPattern table+ where+ table :: [[Operator Parser EgisonPattern]]+ table =+ [ [ Prefix (NotPat <$ symbol "!") ]+ -- 5+ , [ InfixR (inductive2 "cons" ":" )+ , InfixR (inductive2 "join" "++") ]+ -- 3+ , [ InfixR (binary AndPat "&&") ]+ -- 2+ , [ InfixR (binary OrPat "||") ]+ ]+ inductive2 name sym = (\x y -> InductivePat name [x, y]) <$ patOperator sym+ binary name sym = (\x y -> name [x, y]) <$ patOperator sym++applyOrAtomPattern :: Parser EgisonPattern+applyOrAtomPattern = do+ pos <- L.indentLevel+ func <- atomPattern+ args <- many (L.indentGuard sc GT pos *> atomPattern)+ case (func, args) of+ (_, []) -> return func+ (InductivePat x [], _) -> return $ InductivePat x args++atomPattern :: Parser EgisonPattern+atomPattern = do+ pat <- atomPattern'+ indices <- many . try $ char '_' >> atomExpr'+ return $ case indices of+ [] -> pat+ _ -> IndexedPat pat indices++-- atomic pattern without index+atomPattern' :: Parser EgisonPattern+atomPattern' = WildCard <$ symbol "_"+ <|> PatVar <$> patVarLiteral+ <|> ValuePat <$> (char '#' >> atomExpr)+ <|> InductivePat "nil" [] <$ (symbol "[" >> symbol "]")+ <|> InductivePat <$> lowerId <*> pure []+ <|> VarPat <$> (char '~' >> lowerId)+ <|> PredPat <$> (symbol "?" >> atomExpr)+ <|> ContPat <$ symbol "..."+ <|> makeTupleOrParen pattern TuplePat+ <|> seqPattern+ <|> LaterPatVar <$ symbol "@"+ <?> "atomic pattern"++ppPattern :: Parser PrimitivePatPattern+ppPattern = PPInductivePat <$> lowerId <*> many ppAtom+ <|> makeExprParser ppAtom table+ <?> "primitive pattern pattern"+ where+ table :: [[Operator Parser PrimitivePatPattern]]+ table =+ [ [ InfixR (inductive2 "cons" ":" )+ , InfixR (inductive2 "join" "++") ]+ ]+ inductive2 name sym = (\x y -> PPInductivePat name [x, y]) <$ operator sym++ ppAtom :: Parser PrimitivePatPattern+ ppAtom = PPWildCard <$ symbol "_"+ <|> PPPatVar <$ symbol "$"+ <|> PPValuePat <$> (symbol "#$" >> lowerId)+ <|> PPInductivePat "nil" [] <$ brackets sc+ <|> makeTupleOrParen ppPattern PPTuplePat++-- TODO(momohatt): cons pat, snoc pat, empty pat+pdPattern :: Parser PrimitiveDataPattern+pdPattern = PDInductivePat <$> upperId <*> many pdAtom+ <|> pdAtom+ <?> "primitive data pattern"+ where+ pdAtom :: Parser PrimitiveDataPattern+ pdAtom = PDWildCard <$ symbol "_"+ <|> PDPatVar <$> (symbol "$" >> lowerId)+ <|> PDConstantPat <$> constantExpr+ <|> makeTupleOrParen pdPattern PDTuplePat++--+-- Tokens+--++-- space comsumer+sc :: Parser ()+sc = L.space space1 lineCmnt blockCmnt+ where+ lineCmnt = L.skipLineComment "--"+ blockCmnt = L.skipBlockCommentNested "{-" "-}"++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++positiveIntegerLiteral :: Parser Integer+positiveIntegerLiteral = lexeme L.decimal+ <?> "unsinged integer"++charLiteral :: Parser Char+charLiteral = between (char '\'') (symbol "\'") L.charLiteral+ <?> "character"++stringLiteral :: Parser String+stringLiteral = char '\"' *> manyTill L.charLiteral (symbol "\"")+ <?> "string"++boolLiteral :: Parser Bool+boolLiteral = reserved "True" $> True+ <|> reserved "False" $> False+ <?> "boolean"++floatLiteral :: Parser (Double, Double)+floatLiteral = try ((,0) <$> (lexeme L.float <* notFollowedBy (symbol "i")))+ <|> (0,) <$> (lexeme L.float <* symbol "i")+ <?> "float"++varLiteral :: Parser Var+varLiteral = stringToVar <$> lowerId++patVarLiteral :: Parser Var+patVarLiteral = stringToVar <$> (char '$' >> lowerId)++binOpLiteral :: String -> Parser EgisonBinOp+binOpLiteral sym = do+ wedge <- optional (char '!')+ opSym <- operator sym+ let opInfo = fromJust $ find ((== opSym) . repr) reservedBinops+ return $ opInfo { isWedge = isJust wedge }++reserved :: String -> Parser ()+reserved w = (lexeme . try) (string w *> notFollowedBy alphaNumChar)++symbol :: String -> Parser String+symbol sym = try $ L.symbol sc sym++operator :: String -> Parser String+operator sym = try $ string sym <* notFollowedBy opChar <* sc++patOperator :: String -> Parser String+patOperator sym = try $ string sym <* notFollowedBy patOpChar <* sc++-- Characters that could consist expression operators.+opChar :: Parser Char+opChar = oneOf "%^&*-+\\|:<>.?/'!#@$"++-- Characters that could consist pattern operators.+-- ! # @ $ are omitted because they can appear at the beginning of atomPattern+patOpChar :: Parser Char+patOpChar = oneOf "%^&*-+\\|:<>.?/'"++parens = between (symbol "(") (symbol ")")+braces = between (symbol "{") (symbol "}")+brackets = between (symbol "[") (symbol "]")+comma = symbol ","++lowerId :: Parser String+lowerId = (lexeme . try) (p >>= check)+ where+ p = (:) <$> lowerChar <*> many (alphaNumChar <|> oneOf ['.', '?', '\''])+ check x = if x `elem` lowerReservedWords+ then fail $ "keyword " ++ show x ++ " cannot be an identifier"+ else return x++-- TODO: Deprecate BoolExpr and merge it with InductiveDataExpr+upperId :: Parser String+upperId = (lexeme . try) (p >>= check)+ where+ p = (:) <$> upperChar <*> many alphaNumChar+ check x = if x `elem` upperReservedWords+ then fail $ "keyword " ++ show x ++ " cannot be an identifier"+ else return x++keywordLoadFile = reserved "loadFile"+keywordLoad = reserved "load"+keywordIf = reserved "if"+keywordThen = reserved "then"+keywordElse = reserved "else"+keywordSeq = reserved "seq"+keywordApply = reserved "apply"+keywordCApply = reserved "capply"+keywordMemoizedLambda = reserved "memoizedLambda"+keywordCambda = reserved "cambda"+keywordProcedure = reserved "procedure"+keywordMacro = reserved "macro"+keywordLetRec = reserved "letrec"+keywordLet = reserved "let"+keywordIn = reserved "in"+keywordWithSymbols = reserved "withSymbols"+keywordLoop = reserved "loop"+keywordMatch = reserved "match"+keywordMatchDFS = reserved "matchDFS"+keywordMatchAll = reserved "matchAll"+keywordMatchAllDFS = reserved "matchAllDFS"+keywordAs = reserved "as"+keywordWith = reserved "with"+keywordMatcher = reserved "matcher"+keywordDo = reserved "do"+keywordIo = reserved "io"+keywordSomething = reserved "something"+keywordUndefined = reserved "undefined"+keywordAlgebraicDataMatcher = reserved "algebraicDataMatcher"+keywordGenerateTensor = reserved "generateTensor"+keywordTensor = reserved "tensor"+keywordTensorContract = reserved "contract"+keywordSubrefs = reserved "subrefs"+keywordSubrefsNew = reserved "subrefs!"+keywordSuprefs = reserved "suprefs"+keywordSuprefsNew = reserved "suprefs!"+keywordUserrefs = reserved "userRefs"+keywordUserrefsNew = reserved "userRefs!"+keywordFunction = reserved "function"++upperReservedWords =+ [ "True"+ , "False"+ ]++lowerReservedWords =+ [ "loadFile"+ , "load"+ , "if"+ , "then"+ , "else"+ , "seq"+ , "apply"+ , "capply"+ , "memoizedLambda"+ , "cambda"+ , "procedure"+ , "macro"+ , "letrec"+ , "let"+ , "in"+ , "withSymbols"+ , "loop"+ , "from"+ , "to"+ , "of"+ , "match"+ , "matchDFS"+ , "matchAll"+ , "matchAllDFS"+ , "as"+ , "with"+ , "matcher"+ , "do"+ , "io"+ , "something"+ , "undefined"+ , "algebraicDataMatcher"+ , "generateTensor"+ , "tensor"+ , "contract"+ , "subrefs"+ , "subrefs!"+ , "suprefs"+ , "suprefs!"+ , "userRefs"+ , "userRefs!"+ , "function"+ ]++--+-- Utils+--++makeTupleOrParen :: Parser a -> ([a] -> a) -> Parser a+makeTupleOrParen parser tupleCtor = do+ elems <- parens $ sepBy parser comma+ case elems of+ [elem] -> return elem+ _ -> return $ tupleCtor elems++makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr+makeApply (InductiveDataExpr x []) xs = InductiveDataExpr x xs+makeApply func xs = ApplyExpr func (TupleExpr xs)++makeApply' :: String -> [EgisonExpr] -> EgisonExpr+makeApply' func xs = ApplyExpr (stringToVarExpr func) (TupleExpr xs)
− hs-src/Language/Egison/ParserNonS2.y
@@ -1,304 +0,0 @@-{-{-# OPTIONS -w #-}--{- |-Module : Language.Egison.ParserNonS2-Copyright : Satoshi Egi-Licence : MIT--This module provides new Egison parser.--}--module Language.Egison.ParserNonS2- (- -- * Parse a string- readTopExprs- , readTopExpr- , readExprs- , readExpr- , parseTopExprs- , parseTopExpr- , parseExprs- , parseExpr- -- * Parse a file- , loadLibraryFile- , loadFile- ) where--import Control.Monad.Except hiding (mapM)--import Data.Either-import qualified Data.Set as Set--import System.Directory (doesFileExist, getHomeDirectory)--import Language.Egison.Desugar-import Language.Egison.Lexer-import Language.Egison.Types-import Paths_egison (getDataFileName)--}---- %name parseTopExprs_ TopExprs-%name parseTopExpr_ TopExpr-%name parseExpr_ Expr-%tokentype { Token }-%monad { Alex }-%lexer { lexwrap } { Token _ TokenEOF }--- Without this we get a type error-%error { happyError }--%right '|'-%right "++"-%right "||"-%right "&&"-%right ':'-%left '<' '>' "==" "<=" ">="-%left '+' '-' '%'-%left '*' '/'-%left '^'-%right TENSOR--%token- True { Token _ TokenTrue }- False { Token _ TokenFalse }- test { Token _ TokenTest }- match { Token _ TokenMatch }- matchDFS { Token _ TokenMatchDFS }- matchAll { Token _ TokenMatchAll }- matchAllDFS { Token _ TokenMatchAllDFS }- matchLambda { Token _ TokenMatchLambda }- matchAllLambda { Token _ TokenMatchAllLambda }- as { Token _ TokenAs }- with { Token _ TokenWith }- something { Token _ TokenSomething }- if { Token _ TokenIf }- then { Token _ TokenThen }- else { Token _ TokenElse }-- int { Token _ (TokenInt $$) }- var { Token _ (TokenVar $$) }-- "==" { Token _ TokenEqEq }- '<' { Token _ TokenLT }- '>' { Token _ TokenGT }- "<=" { Token _ TokenLE }- ">=" { Token _ TokenGE }- '+' { Token _ TokenPlus }- '-' { Token _ TokenMinus }- '%' { Token _ TokenPercent }- '*' { Token _ TokenAsterisk }- '/' { Token _ TokenDiv }- '^' { Token _ TokenCaret }- "&&" { Token _ TokenAndAnd }- "||" { Token _ TokenBarBar }- ':' { Token _ TokenColon }- ".." { Token _ TokenDotDot }- "++" { Token _ TokenPlusPlus }-- '|' { Token _ TokenBar }- "->" { Token _ TokenArrow }- '$' { Token _ TokenDollar }- '_' { Token _ TokenUnderscore }- '#' { Token _ TokenSharp }- ',' { Token _ TokenComma }- '\\' { Token _ TokenBackSlash }- "*$" { Token _ TokenAstDollar }- '=' { Token _ TokenEq }-- '(' { Token _ TokenLParen }- ')' { Token _ TokenRParen }- '[' { Token _ TokenLBracket }- ']' { Token _ TokenRBracket }--%%---- TopExprs :--- TopExpr { [$1] }--- | TopExpr TopExprs { $1 : $2 }--TopExpr :: { EgisonTopExpr }- : var '=' Expr { Define (stringToVar $1) $3 }- | var list1(Arg) '=' Expr { Define (stringToVar $1) (LambdaExpr $2 $4) }- | Expr { Test $1 }- | test '(' Expr ')' { Test $3 }--Expr :: { EgisonExpr }- : Expr1 { $1 }- | MatchExpr { $1 }- | '\\' list1(Arg) "->" Expr { LambdaExpr $2 $4 }- | if Expr then Expr else Expr { IfExpr $2 $4 $6 }--Expr1 :: { EgisonExpr }- : Atoms { $1 }- | '-' Atom { makeApply (VarExpr $ stringToVar "*") [IntegerExpr(-1), $2] }- | BinOpExpr { $1 }--BinOpExpr :: { EgisonExpr }- : Expr1 "==" Expr1 { makeApply (VarExpr $ stringToVar "eq?") [$1, $3] }- | Expr1 "<=" Expr1 { makeApply (VarExpr $ stringToVar "lte?") [$1, $3] }- | Expr1 '<' Expr1 { makeApply (VarExpr $ stringToVar "lt?") [$1, $3] }- | Expr1 ">=" Expr1 { makeApply (VarExpr $ stringToVar "gte?") [$1, $3] }- | Expr1 '>' Expr1 { makeApply (VarExpr $ stringToVar "gt?") [$1, $3] }- | Expr1 '+' Expr1 { makeApply (VarExpr $ stringToVar "+") [$1, $3] }- | Expr1 '-' Expr1 { makeApply (VarExpr $ stringToVar "-") [$1, $3] }- | Expr1 '%' Expr1 { makeApply (VarExpr $ stringToVar "remainder") [$1, $3] }- | Expr1 '*' Expr1 { makeApply (VarExpr $ stringToVar "*") [$1, $3] }- | Expr1 '/' Expr1 { makeApply (VarExpr $ stringToVar "/") [$1, $3] }- | Expr1 '^' Expr1 { makeApply (VarExpr $ stringToVar "**") [$1, $3] }- | Expr1 "&&" Expr1 { makeApply (VarExpr $ stringToVar "and") [$1, $3] }- | Expr1 "||" Expr1 { makeApply (VarExpr $ stringToVar "or") [$1, $3] }- | Expr1 ':' Expr1 { makeApply (VarExpr $ stringToVar "cons") [$1, $3] }- | Expr1 "++" Expr1 { makeApply (VarExpr $ stringToVar "append") [$1, $3] }--Atoms :: { EgisonExpr }- : Atom { $1 }- | Atom list1(Atom) { makeApply $1 $2 }--MatchExpr :: { EgisonExpr }- : match Expr as Expr with '|' MatchClauses { MatchExpr $2 $4 $7 }- | matchDFS Expr as Expr with '|' MatchClauses { MatchDFSExpr $2 $4 $7 }- | matchAll Expr as Expr with '|' MatchClauses { MatchAllExpr $2 $4 $7 }- | matchAllDFS Expr as Expr with '|' MatchClauses { MatchAllDFSExpr $2 $4 $7 }- | matchLambda as Expr with '|' MatchClauses { MatchLambdaExpr $3 $6 }- | matchAllLambda as Expr with '|' MatchClauses { MatchAllLambdaExpr $3 $6 }--MatchClauses :: { [MatchClause] }- : Pattern "->" Expr { [($1, $3)] }- | MatchClauses '|' Pattern "->" Expr { $1 ++ [($3, $5)] }---- FIXME :--- Uncommenting these 2 rules will yield shift/reduce conflict at--- TopExpr -> var . '=' Expr--- TopExpr -> var . list1__Arg__ '=' Expr--- Atom -> var .-Arg :: { Arg }- : '$' var { ScalarArg $2 }- -- | var { ScalarArg $1 }- | "*$" var { InvertedScalarArg $2 }- -- | '%' var %prec TENSOR { TensorArg $2 }--Atom :: { EgisonExpr }- : int { IntegerExpr $1 }- | var { VarExpr $ stringToVar $1 }- | True { BoolExpr True }- | False { BoolExpr False }- | something { SomethingExpr }- | '(' sep2(Expr, ',') ')' { TupleExpr $2 }- | '[' sep(Expr, ',') ']' { CollectionExpr (map ElementExpr $2) }- | '(' Expr ')' { $2 }- | '[' Expr ".." Expr ']' { makeApply (VarExpr $ stringToVar "between") [$2, $4] }------- Patterns-----Pattern :: { EgisonPattern }- : '_' { WildCard }- | '$' var { PatVar (stringToVar $2) }- | '#' Atom { ValuePat $2 }- | '(' sep2(Pattern, ',') ')' { TuplePat $2 }- | Pattern ':' Pattern { InductivePat "cons" [$1, $3] }- | Pattern "++" Pattern { InductivePat "join" [$1, $3] }------- Helpers (Parameterized Products)-----sep2(p, q) : p q sep1(p, q) { $1 : $3 }-sep1(p, q) : p list(snd(q, p)) { $1 : $2 }-sep(p, q) : sep1(p, q) { $1 }- | { [] }--snd(p, q) : p q { $2 }--list1(p) : rev_list1(p) { reverse $1 }-list(p) : list1(p) { $1 }- | { [] }--rev_list1(p) : p { [$1] }- | rev_list1(p) p { $2 : $1 }--{-makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr-makeApply func xs = do- let args = map (\x -> case x of- LambdaArgExpr s -> Left s- _ -> Right x) xs- let vars = lefts args- case vars of- [] -> ApplyExpr func . TupleExpr $ rights args- _ | all null vars ->- let args' = rights args- args'' = zipWith (curry f) args (annonVars 1 (length args))- args''' = map (VarExpr . stringToVar . either id id) args''- in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'- | all (not . null) vars ->- let n = Set.size $ Set.fromList vars- args' = rights args- args'' = zipWith (curry g) args (annonVars (n + 1) (length args))- args''' = map (VarExpr . stringToVar . either id id) args''- in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'- where- annonVars m n = take n $ map ((':':) . show) [m..]- f (Left _, var) = Left var- f (Right _, var) = Right var- g (Left arg, _) = Left (':':arg)- g (Right _, var) = Right var--lexwrap :: (Token -> Alex a) -> Alex a-lexwrap = (alexMonadScan' >>=)--happyError :: Token -> Alex a-happyError (Token _ TokenEOF) = alexError "unexpected end of input"-happyError (Token p t) = alexError' p ("parse error at token '" ++ show t ++ "'")--readTopExprs :: String -> EgisonM [EgisonTopExpr]-readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs--readTopExpr :: String -> EgisonM EgisonTopExpr-readTopExpr = either throwError desugarTopExpr . parseTopExpr--readExprs :: String -> EgisonM [EgisonExpr]-readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs--readExpr :: String -> EgisonM EgisonExpr-readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr--parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]-parseTopExprs = undefined -- runAlex' parseTopExprs_--parseTopExpr :: String -> Either EgisonError EgisonTopExpr-parseTopExpr = runAlex' parseTopExpr_--parseExprs :: String -> Either EgisonError [EgisonExpr]-parseExprs = undefined--parseExpr :: String -> Either EgisonError EgisonExpr-parseExpr = runAlex' parseExpr_---- |Load a libary file-loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]-loadLibraryFile file = do- homeDir <- liftIO getHomeDirectory- doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file- if doesExist- then loadFile $ homeDir ++ "/.egison/" ++ file- else liftIO (getDataFileName file) >>= loadFile---- |Load a file-loadFile :: FilePath -> EgisonM [EgisonTopExpr]-loadFile file = do- doesExist <- liftIO $ doesFileExist file- unless doesExist $ throwError $ Default ("file does not exist: " ++ file)- input <- liftIO $ readUTF8File file- exprs <- readTopExprs $ shebang input- concat <$> mapM recursiveLoad exprs- where- recursiveLoad (Load file) = loadLibraryFile file- recursiveLoad (LoadFile file) = loadFile file- recursiveLoad expr = return [expr]- shebang :: String -> String- shebang ('#':'!':cs) = ';':'#':'!':cs- shebang cs = cs-}
hs-src/Language/Egison/Primitives.hs view
@@ -9,27 +9,32 @@ This module provides primitive functions in Egison. -} -module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where+module Language.Egison.Primitives+ (+ -- S-syntax version+ primitiveEnv+ , primitiveEnvNoIO+ -- Non-S syntax (Camel case) version+ , primitiveEnv'+ , primitiveEnvNoIO'+ ) where -import Control.Applicative (pure, (*>), (<$>), (<*), (<*>))-import Control.Arrow import Control.Monad.Except import Control.Monad.Trans.Maybe import Data.Foldable (toList) import Data.IORef import Data.Ratio-import Text.Regex.TDFA+import Text.Regex.TDFA ((=~)) import System.IO-import System.Process-import System.Random+import System.Process (readProcess)+import System.Random (getStdRandom, randomR) import qualified Data.Sequence as Sq import qualified Data.Vector as V import Data.Char (chr, ord)-import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -57,6 +62,23 @@ return (stringToVar name, ref) return $ extendEnv nullEnv bindings +-- primitive env for Non-S syntax+primitiveEnv' :: IO Env+primitiveEnv' = do+ let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) (primitives' ++ ioPrimitives')+ bindings <- forM (constants ++ ops) $ \(name, op) -> do+ ref <- newIORef . WHNF $ Value op+ return (stringToVar name, ref)+ return $ extendEnv nullEnv bindings++primitiveEnvNoIO' :: IO Env+primitiveEnvNoIO' = do+ let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) primitives'+ bindings <- forM (constants ++ ops) $ \(name, op) -> do+ ref <- newIORef . WHNF $ Value op+ return (stringToVar name, ref)+ return $ extendEnv nullEnv bindings+ {-# INLINE noArg #-} noArg :: EgisonM EgisonValue -> PrimitiveFunc noArg f args = do@@ -231,6 +253,112 @@ , ("assert-equal", assertEqual) ] +-- for Non-S syntax+primitives' :: [(String, PrimitiveFunc)]+primitives' = [ ("b.+", plus)+ , ("b.-", minus)+ , ("b.*", multiply)+ , ("b./", divide)+ , ("b.+'", plus)+ , ("b.-'", minus)+ , ("b.*'", multiply)+ , ("b./'", divide)+ , ("f.+", floatPlus)+ , ("f.-", floatMinus)+ , ("f.*", floatMult)+ , ("f./", floatDivide)+ , ("numerator", numerator')+ , ("denominator", denominator')+ , ("fromMathExpr", fromScalarData)+ , ("toMathExpr", toScalarData)+ , ("toMathExpr'", toScalarData)++ , ("modulo", integerBinaryOp mod)+ , ("quotient", integerBinaryOp quot)+ , ("remainder", integerBinaryOp rem)+ , ("b.abs", rationalUnaryOp abs)+ , ("b.neg", rationalUnaryOp negate)++ , ("eq?", eq)+ , ("lt?", lt)+ , ("lte?", lte)+ , ("gt?", gt)+ , ("gte?", gte)++ , ("round", floatToIntegerOp round)+ , ("floor", floatToIntegerOp floor)+ , ("ceiling", floatToIntegerOp ceiling)+ , ("truncate", truncate')+ , ("realPart", realPart)+ , ("imaginaryPart", imaginaryPart)++ , ("b.sqrt", floatUnaryOp sqrt)+ , ("b.sqrt'", floatUnaryOp sqrt)+ , ("b.exp", floatUnaryOp exp)+ , ("b.log", floatUnaryOp log)+ , ("b.sin", floatUnaryOp sin)+ , ("b.cos", floatUnaryOp cos)+ , ("b.tan", floatUnaryOp tan)+ , ("b.asin", floatUnaryOp asin)+ , ("b.acos", floatUnaryOp acos)+ , ("b.atan", floatUnaryOp atan)+ , ("b.sinh", floatUnaryOp sinh)+ , ("b.cosh", floatUnaryOp cosh)+ , ("b.tanh", floatUnaryOp tanh)+ , ("b.asinh", floatUnaryOp asinh)+ , ("b.acosh", floatUnaryOp acosh)+ , ("b.atanh", floatUnaryOp atanh)++ , ("tensorSize", tensorSize')+ , ("tensorToList", tensorToList')+ , ("dfOrder", dfOrder')++ , ("itof", integerToFloat)+ , ("rtof", rationalToFloat)+ , ("ctoi", charToInteger)+ , ("itoc", integerToChar)++ , ("pack", pack)+ , ("unpack", unpack)+ , ("unconsString", unconsString)+ , ("lengthString", lengthString)+ , ("appendString", appendString)+ , ("splitString", splitString)+ , ("regex", regexString)+ , ("regexCg", regexStringCaptureGroup)++ , ("addPrime", addPrime)+ , ("addSubscript", addSubscript)+ , ("addSuperscript", addSuperscript)++ , ("readProcess", readProcess')++ , ("read", read')+ , ("readTsv", readTSV)+ , ("show", show')+ , ("showTsv", showTSV')++ , ("empty?", isEmpty')+ , ("uncons", uncons')+ , ("unsnoc", unsnoc')++ , ("bool?", isBool')+ , ("integer?", isInteger')+ , ("rational?", isRational')+ , ("scalar?", isScalar')+ , ("float?", isFloat')+ , ("char?", isChar')+ , ("string?", isString')+ , ("collection?", isCollection')+ , ("array?", isArray')+ , ("hash?", isHash')+ , ("tensor?", isTensor')+ , ("tensorWithIndex?", isTensorWithIndex')++ , ("assert", assert)+ , ("assertEqual", assertEqual)+ ]+ rationalUnaryOp :: (Rational -> Rational) -> PrimitiveFunc rationalUnaryOp op = oneArg $ \val -> do r <- fromEgison val@@ -657,6 +785,35 @@ , ("eof-port?", isEOFPort) , ("flush-port", flushPort) , ("read-file", readFile')++ , ("rand", randRange)+ , ("f.rand", randRangeDouble)+-- , ("sqlite", sqlite)+ ]++-- For Non-S syntax+ioPrimitives' :: [(String, PrimitiveFunc)]+ioPrimitives' = [+ ("return", return')+ , ("openInputFile", makePort ReadMode)+ , ("openOutputFile", makePort WriteMode)+ , ("closeInputPort", closePort)+ , ("closeOutputPort", closePort)+ , ("readChar", readChar)+ , ("readLine", readLine)+ , ("writeChar", writeChar)+ , ("write", writeString)++ , ("readCharFromPort", readCharFromPort)+ , ("readLineFromPort", readLineFromPort)+ , ("writeCharToPort", writeCharToPort)+ , ("writeToPort", writeStringToPort)++ , ("eof?", isEOFStdin)+ , ("flush", flushStdout)+ , ("eofPort?", isEOFPort)+ , ("flushPort", flushPort)+ , ("readFile", readFile') , ("rand", randRange) , ("f.rand", randRangeDouble)
hs-src/Language/Egison/Types.hs view
@@ -34,6 +34,9 @@ , PrimitiveFunc (..) , EgisonData (..) , showTSV+ , EgisonBinOp(..)+ , BinOpAssoc(..)+ , reservedBinops -- * Egison values , EgisonValue (..) , ScalarData (..)@@ -154,6 +157,7 @@ , isHash' , readUTF8File , stringToVar+ , stringToVarExpr , varToVarWithIndices , EgisonOpts (..) , defaultOption@@ -164,7 +168,6 @@ import Control.Exception import Data.Typeable -import Control.Applicative import Control.Monad.Except import Control.Monad.Fail import Control.Monad.Identity@@ -176,26 +179,23 @@ import qualified Data.Array as Array import Data.Foldable (foldr, toList) import Data.Hashable (Hashable)-import qualified Data.HashMap.Lazy as HL import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.IORef-import Data.Map (Map) import Data.Monoid (Monoid) import Data.Sequence (Seq) import qualified Data.Sequence as Sq import qualified Data.Vector as V -import Data.List (any, delete, deleteBy, elem,- elemIndex, find, findIndex,- intercalate, partition, sort,- sortBy, splitAt, (\\))+import Data.List (any, delete, elem, elemIndex, find,+ findIndex, intercalate, partition,+ splitAt, (\\)) import Data.List.Split (splitOn)-import Data.Text (Text, pack)+import Data.Text (Text) import qualified Data.Text as T import Data.Ratio-import Numeric+import Numeric (showFFloat) import System.IO import System.IO.Unsafe (unsafePerformIO)@@ -228,10 +228,10 @@ | SubrefsExpr Bool EgisonExpr EgisonExpr | SuprefsExpr Bool EgisonExpr EgisonExpr | UserrefsExpr Bool EgisonExpr EgisonExpr- | PowerExpr EgisonExpr EgisonExpr+ | PowerExpr EgisonExpr EgisonExpr -- TODO: delete this in v4.0.0 | InductiveDataExpr String [EgisonExpr] | TupleExpr [EgisonExpr]- | CollectionExpr [InnerExpr]+ | CollectionExpr [InnerExpr] -- TODO: InnerExpr should be EgisonExpr from v4.0.0 | ArrayExpr [EgisonExpr] | HashExpr [(EgisonExpr, EgisonExpr)] | VectorExpr [EgisonExpr]@@ -264,18 +264,20 @@ | QuoteExpr EgisonExpr | QuoteSymbolExpr EgisonExpr - | WedgeExpr EgisonExpr- | WedgeApplyExpr EgisonExpr EgisonExpr+ | WedgeExpr EgisonExpr -- Desugared to WedgeApplyExpr+ | WedgeApplyExpr EgisonExpr EgisonExpr -- Appears after desugar | DoExpr [BindingExpr] EgisonExpr | IoExpr EgisonExpr + | UnaryOpExpr String EgisonExpr+ | BinaryOpExpr EgisonBinOp EgisonExpr EgisonExpr+ | SeqExpr EgisonExpr EgisonExpr | ApplyExpr EgisonExpr EgisonExpr | CApplyExpr EgisonExpr EgisonExpr | PartialExpr Integer EgisonExpr | PartialVarExpr Integer- | RecVarExpr | GenerateArrayExpr EgisonExpr (EgisonExpr, EgisonExpr) | ArrayBoundsExpr EgisonExpr@@ -323,6 +325,7 @@ type MatchClause = (EgisonPattern, EgisonExpr) type MatcherInfo = [(PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])] +-- TODO(momohatt): AndPat and OrPat take only 2 arguments in new syntax data EgisonPattern = WildCard | PatVar Var@@ -373,6 +376,52 @@ | PDConstantPat EgisonExpr deriving (Show, Eq) +data EgisonBinOp+ = EgisonBinOp { repr :: String -- syntastic representation+ , func :: String -- semantics+ , priority :: Int+ , assoc :: BinOpAssoc+ , isWedge :: Bool -- True if operator is prefixed with '!'+ }+ deriving (Eq, Ord)++data BinOpAssoc+ = LeftAssoc+ | RightAssoc+ | NonAssoc+ deriving (Eq, Ord)++instance Show EgisonBinOp where+ show op = repr op++instance Show BinOpAssoc where+ show LeftAssoc = "infixl"+ show RightAssoc = "infixr"+ show NonAssoc = "infix"++reservedBinops :: [EgisonBinOp]+reservedBinops =+ [ makeBinOp "^" "**" 8 LeftAssoc+ , makeBinOp "*" "*" 7 LeftAssoc+ , makeBinOp "/" "/" 7 LeftAssoc+ , makeBinOp "%" "remainder" 7 LeftAssoc+ , makeBinOp "+" "+" 6 LeftAssoc+ , makeBinOp "-" "-" 6 LeftAssoc+ , makeBinOp "++" "append" 5 RightAssoc+ , makeBinOp ":" "cons" 5 RightAssoc+ , makeBinOp "==" "eq?" 4 LeftAssoc+ , makeBinOp "<=" "lte?" 4 LeftAssoc+ , makeBinOp ">=" "gte?" 4 LeftAssoc+ , makeBinOp "<" "lt?" 4 LeftAssoc+ , makeBinOp ">" "gt?" 4 LeftAssoc+ , makeBinOp "&&" "and" 3 RightAssoc+ , makeBinOp "||" "or" 2 RightAssoc+ ]+ where+ makeBinOp r f p a =+ EgisonBinOp { repr = r, func = f, priority = p, assoc = a, isWedge = False }++ -- -- Values --@@ -439,11 +488,9 @@ _ == _ = False instance Eq TermExpr where- (Term a []) == (Term b [])- | a /= b = False- | otherwise = True+ (Term a []) == (Term b []) = a == b (Term a ((Quote x, n):xs)) == (Term b ys)- | (a /= b) && (a /= negate b) = False+ | (a /= b) && (a /= negate b) = False | otherwise = case elemIndex (Quote x, n) ys of Just i -> let (hs, _:ts) = splitAt i ys in Term a xs == Term b (hs ++ ts)@@ -454,7 +501,7 @@ else Term (negate a) xs == Term b (hs ++ ts) Nothing -> False (Term a (x:xs)) == (Term b ys)- | (a /= b) && (a /= negate b) = False+ | (a /= b) && (a /= negate b) = False | otherwise = case elemIndex x ys of Just i -> let (hs, _:ts) = splitAt i ys in Term a xs == Term b (hs ++ ts)@@ -527,9 +574,10 @@ ) js)) symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n] symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]-symbolExprToEgison (FunctionData name argnames args js, n) = case name of- Nothing -> Tuple [InductiveData "Function" [symbolScalarData "" "", Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n]- Just name' -> Tuple [InductiveData "Function" [name', Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n]+symbolExprToEgison (FunctionData name argnames args js, n) =+ case name of+ Nothing -> Tuple [InductiveData "Function" [symbolScalarData "" "", Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n]+ Just name' -> Tuple [InductiveData "Function" [name', Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n] where f js = Collection (Sq.fromList (map (\case Superscript k -> InductiveData "Sup" [ScalarData k]@@ -1202,6 +1250,12 @@ show (TupleExpr exprs) = "[" ++ unwords (map show exprs) ++ "]" show (CollectionExpr ls) = "{" ++ unwords (map show ls) ++ "}" + show (UnaryOpExpr op e) = op ++ " " ++ show e+ show (BinaryOpExpr op e1 e2) = "(" ++ show e1 ++ " " ++ show op ++ " " ++ show e2 ++ ")"++ show (QuoteExpr e) = "'" ++ show e+ show (QuoteSymbolExpr e) = "`" ++ show e+ show (ApplyExpr fn (TupleExpr [])) = "(" ++ show fn ++ ")" show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")" show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")"@@ -1652,6 +1706,7 @@ | NotImplemented String CallStack | Assertion String CallStack | Parser String+ | ParserUnexpectedEOF | EgisonBug String CallStack | MatchFailure String CallStack | Default String@@ -1674,8 +1729,9 @@ show (NotImplemented message stack) = "Not implemented: " ++ message ++ showTrace stack show (Assertion message stack) = "Assertion failed: " ++ message ++ showTrace stack show (Parser err) = "Parse error at: " ++ err+ show ParserUnexpectedEOF = "Parser error: unexpected end of input" show (EgisonBug message stack) = "Egison Error: " ++ message ++ showTrace stack- show (MatchFailure currentFunc stack) = "Failed pattern match at: " ++ currentFunc ++ showTrace stack+ show (MatchFailure currentFunc stack) = "Failed pattern match in: " ++ currentFunc ++ showTrace stack show (Default message) = "Error: " ++ message showTrace :: CallStack -> String@@ -1728,9 +1784,9 @@ return result data RuntimeState = RuntimeState- -- | index counter for generating fresh variable+ -- index counter for generating fresh variable { indexCounter :: Int- -- | names of called functions for improved error message+ -- names of called functions for improved error message , funcNameStack :: [String] } @@ -1953,6 +2009,9 @@ stringToVar :: String -> Var stringToVar name = Var (splitOn "." name) [] +stringToVarExpr :: String -> EgisonExpr+stringToVarExpr = VarExpr . stringToVar+ varToVarWithIndices :: Var -> VarWithIndices varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is where@@ -1983,7 +2042,7 @@ optPrompt :: String, optMathExpr :: Maybe String, optSExpr :: Bool,- optUseHappy :: Bool+ optUseNonS2 :: Bool } defaultOption :: EgisonOpts
hs-src/Language/Egison/Util.hs view
@@ -6,13 +6,16 @@ This module provides utility functions. -} -module Language.Egison.Util (getEgisonExpr, getEgisonExprOrNewLine, completeEgison) where+module Language.Egison.Util+ ( getEgisonExpr+ , completeEgison+ ) where import Control.Monad.Except (liftIO) import Data.List import System.Console.Haskeline hiding (catch, handle, throwTo) import System.Console.Haskeline.History (addHistoryUnlessConsecutiveDupe)-import Text.Regex.TDFA+import Text.Regex.TDFA ((=~)) import Language.Egison.Parser as Parser import Language.Egison.ParserNonS as ParserNonS@@ -38,7 +41,7 @@ history <- getHistory putHistory $ addHistoryUnlessConsecutiveDupe line history let input = prev ++ line- let parsedExpr = (if optUseHappy opts then ParserNonS2.parseTopExpr else if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input+ let parsedExpr = (if optUseNonS2 opts then ParserNonS2.parseTopExpr else if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input case parsedExpr of Left err | show err =~ "unexpected end of input" -> getEgisonExpr' opts $ input ++ "\n"@@ -46,29 +49,6 @@ liftIO $ print err getEgisonExpr opts Right topExpr -> return $ Just (input, topExpr)---- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExprOrNewLine :: EgisonOpts -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))-getEgisonExprOrNewLine opts = getEgisonExprOrNewLine' opts ""--getEgisonExprOrNewLine' :: EgisonOpts -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))-getEgisonExprOrNewLine' opts prev = do- mLine <- case prev of- "" -> getInputLine $ optPrompt opts- _ -> getInputLine $ replicate (length $ optPrompt opts) ' '- case mLine of- Nothing -> return $ Left Nothing- Just [] -> return $ Left $ Just ""- Just line -> do- let input = prev ++ line- let parsedExpr = (if optUseHappy opts then ParserNonS2.parseTopExpr else if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input- case parsedExpr of- Left err | show err =~ "unexpected end of input" ->- getEgisonExprOrNewLine' opts $ input ++ "\n"- Left err -> do- liftIO $ print err- getEgisonExprOrNewLine opts- Right topExpr -> return $ Right (input, topExpr) -- |Complete Egison keywords completeEgison :: Monad m => CompletionFunc m
lib/core/order.egi view
@@ -91,3 +91,10 @@ [[<cons $x $txs> <cons ?1#(eq? (f %1 x) <Greater>) _>] {x @(merge txs ys)}] [[_ <cons $y $tys>] {y @(merge xs tys)}]}))) +(define $minimize+ (lambda [$f $xs]+ (foldl 2#(if (eq? (compare (f %1) (f %2)) <Less>) %1 %2) (car xs) (cdr xs))))++(define $maximize+ (lambda [$f $xs]+ (foldl 2#(if (eq? (compare (f %1) (f %2)) <Greater>) %1 %2) (car xs) (cdr xs))))
lib/core/string.egi view
@@ -97,19 +97,19 @@ ;; ;; Alphabet ;;-(define $c.between+(define $C.between (lambda [$c1 $c2] (map itoc (between (ctoi c1) (ctoi c2))))) -(define $c.between?+(define $C.between? (lambda [$c1 $c2 $c] (and (gte? (ctoi c) (ctoi c1)) (lte? (ctoi c) (ctoi c2))))) (define $alphabet? (lambda [$c]- (or (c.between? c#a c#z c)- (c.between? c#A c#Z c))))+ (or (C.between? c#a c#z c)+ (C.between? c#A c#Z c)))) (define $alphabets? (lambda [$s]@@ -117,12 +117,12 @@ (define $upper-case (lambda [$c]- (if (c.between? c#a c#z c)+ (if (C.between? c#a c#z c) (itoc (- (ctoi c) 32)) c))) (define $lower-case (lambda [$c]- (if (c.between? c#A c#Z c)+ (if (C.between? c#A c#Z c) (itoc (+ (ctoi c) 32)) c)))
test/Test.hs view
@@ -15,31 +15,75 @@ import Language.Egison import Language.Egison.Core-import Language.Egison.Parser+import qualified Language.Egison.Parser as Parser+import qualified Language.Egison.ParserNonS2 as ParserNonS2 import Language.Egison.Primitives import Language.Egison.Types +main :: IO () main = do- (sampleTestCases, unitTestCases) <- partition (isSubsequenceOf "answer" . show) <$> glob "test/**/*.egi"- defaultMain $ hUnitTestToTests $ test $ map runUnitTestCase unitTestCases ++ map runSampleTestCase sampleTestCases+ let unitTests = map runUnitTestCase unitTestCases+ unitNonSTests = map runUnitTestCaseNonS unitNonSTestCases+ sampleTests = map runSampleTestCase sampleTestCases+ in defaultMain . hUnitTestToTests . test $ unitNonSTests ++ unitTests ++ sampleTests +unitTestCases :: [FilePath]+unitTestCases =+ [ "test/syntax.egi"+ , "test/primitive.egi"+ , "test/lib/math/analysis.egi"+ , "test/lib/math/tensor.egi"+ , "test/lib/math/arithmetic.egi"+ , "test/lib/math/algebra.egi"+ , "test/lib/core/string.egi"+ , "test/lib/core/base.egi"+ , "test/lib/core/collection.egi"+ , "test/lib/core/order.egi"+ , "test/lib/core/number.egi"+ ]++unitNonSTestCases :: [FilePath]+unitNonSTestCases =+ [+-- "nons-test/test/syntax.egi"+-- , "nons-test/test/primitive.egi"+-- , "nons-test/test/lib/core/base.egi"+-- , "nons-test/test/lib/core/order.egi"+ ]++sampleTestCases :: [FilePath]+sampleTestCases =+ [ "test/answer/sample/poker-hands-with-joker.egi"+ , "test/answer/sample/primes.egi"+ , "test/answer/sample/mahjong.egi"+ , "test/answer/sample/poker-hands.egi"+ , "test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi"+ , "test/answer/sample/math/number/17th-root-of-unity.egi"+ ]+ runUnitTestCase :: FilePath -> Test runUnitTestCase file = TestLabel file . TestCase $ do env <- initialEnv defaultOption assertEgisonM $ do- exprs <- loadFile file+ exprs <- Parser.loadFile file let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs env' <- recursiveBind env bindings forM_ tests $ evalExprDeep env'- where- assertEgisonM :: EgisonM a -> Assertion- assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")+ where+ assertEgisonM :: EgisonM a -> Assertion+ assertEgisonM m = fromEgisonM m >>= assertString . either show (const "") - collectDefsAndTests (Define name expr) (bindings, tests) =- ((name, expr) : bindings, tests)- collectDefsAndTests (Test expr) (bindings, tests) =- (bindings, expr : tests)- collectDefsAndTests _ r = r+runUnitTestCaseNonS :: FilePath -> Test+runUnitTestCaseNonS file = TestLabel file . TestCase $ do+ env <- initialEnv (defaultOption { optUseNonS2 = True })+ assertEgisonM $ do+ exprs <- ParserNonS2.loadFile file+ let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs+ env' <- recursiveBind env bindings+ forM_ tests $ evalExprDeep env'+ where+ assertEgisonM :: EgisonM a -> Assertion+ assertEgisonM m = fromEgisonM m >>= assertString . either show (const "") runSampleTestCase :: FilePath -> Test runSampleTestCase file = TestLabel file . TestCase $ do@@ -47,26 +91,26 @@ let directory_path = takeDirectory file answers <- readFile file assertEgisonM (lines answers) $ do- exprs <- loadFile (replaceDirectory file $ concat $ drop 2 $ splitPath directory_path)+ exprs <- Parser.loadFile (replaceDirectory file $ concat $ drop 2 $ splitPath directory_path) let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs env' <- recursiveBind env bindings vals <- forM tests (evalExprDeep env') return $ zip tests vals- where- assertEgisonM :: [String] -> EgisonM [(EgisonExpr, EgisonValue)] -> Assertion- assertEgisonM answers m = fromEgisonM m >>= assertString . either show (f answers)-- collectDefsAndTests (Define name expr) (bindings, tests) =- ((name, expr) : bindings, tests)- collectDefsAndTests (Test expr) (bindings, tests) =- (bindings, expr : tests)- collectDefsAndTests _ r = r+ where+ assertEgisonM :: [String] -> EgisonM [(EgisonExpr, EgisonValue)] -> Assertion+ assertEgisonM answers m = fromEgisonM m >>= assertString . either show (f answers) - f :: [String] -> [(EgisonExpr, EgisonValue)] -> String- f answers ls = g answers ls 0- g x y i = let (e, v) = unzip y in- if (x !! i) == show (v !! i)- then (if i < (length y - 1) then g x y (i + 1)- else "")- else "failed " ++ show (e !! i) ++ "\n expected: " ++ (x !! i) ++ "\n but found: " ++ show (v !! i)+ f :: [String] -> [(EgisonExpr, EgisonValue)] -> String+ f answers ls = g answers ls 0+ g x y i = let (e, v) = unzip y in+ if (x !! i) == show (v !! i)+ then (if i < (length y - 1) then g x y (i + 1)+ else "")+ else "failed " ++ show (e !! i) ++ "\n expected: " ++ (x !! i) ++ "\n but found: " ++ show (v !! i) +collectDefsAndTests :: EgisonTopExpr -> ([(Var, EgisonExpr)], [EgisonExpr]) -> ([(Var, EgisonExpr)], [EgisonExpr])+collectDefsAndTests (Define name expr) (bindings, tests) =+ ((name, expr) : bindings, tests)+collectDefsAndTests (Test expr) (bindings, tests) =+ (bindings, expr : tests)+collectDefsAndTests _ r = r