diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.9.3 +Version: 3.9.4 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. @@ -61,8 +61,12 @@ Data-files: lib/core/*.egi lib/math/*.egi lib/math/common/*.egi lib/math/algebra/*.egi lib/math/analysis/*.egi lib/math/geometry/*.egi sample/*.egi sample/io/*.egi sample/math/algebra/*.egi sample/math/analysis/*.egi sample/math/geometry/*.egi sample/math/number/*.egi sample/math/others/*.egi + test/*.egi test/lib/core/*.egi test/lib/math/*.egi + nons-test/test/*.egi nons-test/test/lib/core/*.egi + test/answer/sample/*.egi test/answer/sample/math/geometry/*.egi test/answer/sample/math/number/*.egi elisp/egison-mode.el + source-repository head type: git location: https://github.com/egison/egison.git @@ -89,6 +93,7 @@ , vector , split , hashable + , prettyprinter if !impl(ghc > 8.0) Build-Depends: fail Hs-Source-Dirs: hs-src @@ -99,7 +104,7 @@ Language.Egison.Types Language.Egison.Parser Language.Egison.ParserNonS - Language.Egison.ParserNonS2 + Language.Egison.Pretty Language.Egison.Primitives Language.Egison.Util Language.Egison.MathOutput @@ -160,3 +165,12 @@ Hs-Source-Dirs: hs-src/Interpreter Other-modules: Paths_egison ghc-options: -O3 -threaded -eventlog -rtsopts + +Executable egison-translate + Main-is: translator.hs + Build-depends: + egison + , base >= 4.0 && < 5 + , prettyprinter + , split + Hs-Source-Dirs: hs-src/Tool diff --git a/hs-src/Interpreter/egison.hs b/hs-src/Interpreter/egison.hs --- a/hs-src/Interpreter/egison.hs +++ b/hs-src/Interpreter/egison.hs @@ -111,10 +111,7 @@ <*> flag True False (short 'N' <> long "new-syntax" - <> help "Use non-S-expressoin syntax") - <*> flag False True - (long "N2" - <> help "[experimental] Use new lexer and parser") + <> help "[experimental] Use non-S expression syntax") readFieldOption :: String -> (String, String) readFieldOption str = diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -37,7 +37,6 @@ import Language.Egison.MathOutput (changeOutputInLang) import Language.Egison.Parser as Parser import Language.Egison.ParserNonS as ParserNonS -import Language.Egison.ParserNonS2 as ParserNonS2 import Language.Egison.Primitives import Language.Egison.Types @@ -80,30 +79,26 @@ -- |eval an Egison expression. Input is a Haskell string. runEgisonExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError EgisonValue) runEgisonExpr opts env input - | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readExpr input >>= evalExprDeep env - | optSExpr opts = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env - | otherwise = fromEgisonM $ ParserNonS.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 - | 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 + | 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 - | 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 + | 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 - | 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 + | optSExpr opts = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs opts env + | otherwise = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs opts env -- |load an Egison file loadEgisonFile :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env) @@ -116,10 +111,10 @@ -- |Environment that contains core libraries initialEnv :: EgisonOpts -> IO Env initialEnv opts = do - env <- if optNoIO opts then if optUseNonS2 opts then primitiveEnvNoIO' - else primitiveEnvNoIO - else if optUseNonS2 opts then primitiveEnv' - else primitiveEnv + env <- if optNoIO opts then if optSExpr opts then primitiveEnvNoIO + else primitiveEnvNoIO' + else if optSExpr opts then primitiveEnv + else primitiveEnv' ret <- evalEgisonTopExprs defaultOption env $ map Load coreLibraries case ret of Left err -> do diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -66,7 +66,6 @@ import Language.Egison.Parser as Parser import Language.Egison.ParserNonS as ParserNonS -import Language.Egison.ParserNonS2 as ParserNonS2 import Language.Egison.Types -- @@ -84,7 +83,6 @@ if optNoIO opts then throwError $ Default "No IO support" else do exprs' <- if - | optUseNonS2 opts -> ParserNonS2.loadFile file | optSExpr opts -> Parser.loadFile file | otherwise -> ParserNonS.loadFile file collectDefs opts (exprs' ++ exprs) bindings rest @@ -92,7 +90,6 @@ if optNoIO opts then throwError $ Default "No IO support" else do exprs' <- if - | optUseNonS2 opts -> ParserNonS2.loadLibraryFile file | optSExpr opts -> Parser.loadLibraryFile file | otherwise -> ParserNonS.loadLibraryFile file collectDefs opts (exprs' ++ exprs) bindings rest @@ -126,7 +123,7 @@ evalExpr _ (StringExpr s) = return $ Value $ toEgison s evalExpr _ (BoolExpr b) = return . Value $ Bool b evalExpr _ (IntegerExpr x) = return . Value $ toEgison x -evalExpr _ (FloatExpr x y) = return . Value $ Float x y +evalExpr _ (FloatExpr x) = return . Value $ Float x evalExpr env (QuoteExpr expr) = do whnf <- evalExpr env expr @@ -1553,7 +1550,7 @@ extractPrimitiveValue (Value val@(Char _)) = return val extractPrimitiveValue (Value val@(Bool _)) = return val extractPrimitiveValue (Value val@(ScalarData _)) = return val -extractPrimitiveValue (Value val@(Float _ _)) = return val +extractPrimitiveValue (Value val@(Float _)) = return val extractPrimitiveValue whnf = -- we don't need to extract call stack since detailed error information is not used throwError $ TypeMismatch "primitive value" whnf @@ -1562,5 +1559,5 @@ isPrimitiveValue (Value (Char _)) = True isPrimitiveValue (Value (Bool _)) = True isPrimitiveValue (Value (ScalarData _)) = True -isPrimitiveValue (Value (Float _ _)) = True +isPrimitiveValue (Value (Float _)) = True isPrimitiveValue _ = False diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -13,62 +13,35 @@ module Language.Egison.Desugar ( - DesugarM - , runDesugarM - , desugarTopExpr + desugarTopExpr , desugarExpr - , desugar ) where -import Control.Applicative (Applicative, pure, (<$>), (<*>)) -import Control.Monad.Except -import Control.Monad.Fail -import Control.Monad.Reader import Data.Char (toUpper) -import Data.List (find, span) -import Data.Maybe (fromJust, fromMaybe) +import Data.List (span) import Data.Set (Set) import qualified Data.Set as S import Language.Egison.Types -type Subst = [(String, EgisonExpr)] - -newtype DesugarM a = DesugarM { unDesugarM :: ReaderT Subst (ExceptT EgisonError Fresh) a } - deriving (Functor, Applicative, Monad, MonadError EgisonError, MonadFresh, MonadReader Subst) - -instance MonadFail DesugarM where - fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack - -runDesugarM :: DesugarM a -> Fresh (Either EgisonError a) -runDesugarM = runExceptT . flip runReaderT [] . unDesugarM - desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr -desugarTopExpr (Define name expr) = do - expr' <- liftEgisonM $ runDesugarM $ desugar expr - return (Define name expr') -desugarTopExpr (Redefine name expr) = do - expr' <- liftEgisonM $ runDesugarM $ desugar expr - return (Redefine name expr') -desugarTopExpr (Test expr) = do - expr' <- liftEgisonM $ runDesugarM $ desugar expr - return (Test expr') -desugarTopExpr (Execute expr) = do - expr' <- liftEgisonM $ runDesugarM $ desugar expr - return (Execute expr') -desugarTopExpr expr = return expr +desugarTopExpr (Define name expr) = Define name <$> desugar expr +desugarTopExpr (Redefine name expr) = Redefine name <$> desugar expr +desugarTopExpr (Test expr) = Test <$> desugar expr +desugarTopExpr (Execute expr) = Execute <$> desugar expr +desugarTopExpr expr = return expr desugarExpr :: EgisonExpr -> EgisonM EgisonExpr -desugarExpr expr = liftEgisonM $ runDesugarM $ desugar expr +desugarExpr = desugar -desugar :: EgisonExpr -> DesugarM EgisonExpr +desugar :: EgisonExpr -> EgisonM EgisonExpr desugar (AlgebraicDataMatcherExpr patterns) = do matcherName <- freshV let matcherRef = VarExpr matcherName matcher <- genMatcherClauses patterns matcherRef return $ LetRecExpr [([matcherName], matcher)] matcherRef where - genMatcherClauses :: [(String, [EgisonExpr])] -> EgisonExpr -> DesugarM EgisonExpr + genMatcherClauses :: [(String, [EgisonExpr])] -> EgisonExpr -> EgisonM EgisonExpr genMatcherClauses patterns matcher = do main <- genMainClause patterns matcher body <- mapM genMatcherClause patterns @@ -76,7 +49,7 @@ let clauses = [main] ++ body ++ [footer] return $ MatcherExpr clauses - genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) + genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genMainClause patterns matcher = do clauses <- genClauses patterns return (PPValuePat "val", TupleExpr [] @@ -84,34 +57,34 @@ (TupleExpr [matcher, matcher]) clauses)]) where - genClauses :: [(String, [EgisonExpr])] -> DesugarM [MatchClause] + genClauses :: [(String, [EgisonExpr])] -> EgisonM [MatchClause] genClauses patterns = (++) <$> mapM genClause patterns <*> pure [(TuplePat [WildCard, WildCard], matchingFailure)] - genClause :: (String, [EgisonExpr]) -> DesugarM MatchClause + genClause :: (String, [EgisonExpr]) -> EgisonM MatchClause genClause pattern = do (pat0, pat1) <- genMatchingPattern pattern return (TuplePat [pat0, pat1], matchingSuccess) - genMatchingPattern :: (String, [EgisonExpr]) -> DesugarM (EgisonPattern, EgisonPattern) + genMatchingPattern :: (String, [EgisonExpr]) -> EgisonM (EgisonPattern, EgisonPattern) genMatchingPattern (name, patterns) = do names <- mapM (const freshV) patterns return (InductivePat name (map PatVar names), InductivePat name (map (ValuePat . VarExpr) names)) - genMatcherClause :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) + genMatcherClause :: (String, [EgisonExpr]) -> EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genMatcherClause pattern = do (ppat, matchers) <- genPrimitivePatPat pattern (dpat, body) <- genPrimitiveDataPat pattern return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)]) where - genPrimitivePatPat :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, [EgisonExpr]) + genPrimitivePatPat :: (String, [EgisonExpr]) -> EgisonM (PrimitivePatPattern, [EgisonExpr]) genPrimitivePatPat (name, matchers) = do patterns' <- mapM (const $ return PPPatVar) matchers return (PPInductivePat name patterns', matchers) - genPrimitiveDataPat :: (String, [EgisonExpr]) -> DesugarM (PrimitiveDataPattern, [EgisonExpr]) + genPrimitiveDataPat :: (String, [EgisonExpr]) -> EgisonM (PrimitiveDataPattern, [EgisonExpr]) genPrimitiveDataPat (name, patterns) = do patterns' <- mapM (const freshV) patterns return (PDInductivePat (capitalize name) $ map (PDPatVar . show) patterns', map VarExpr patterns') @@ -120,7 +93,7 @@ capitalize (x:xs) = toUpper x : xs - genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) + genSomethingClause :: EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genSomethingClause = return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (stringToVarExpr "tgt")])]) @@ -186,10 +159,8 @@ desugar (UserrefsExpr bool expr1 expr2) = UserrefsExpr bool <$> desugar expr1 <*> desugar expr2 -desugar (PowerExpr expr1 expr2) = do - expr1' <- desugar expr1 - expr2' <- desugar expr2 - return $ ApplyExpr (stringToVarExpr "**") (TupleExpr [expr1', expr2']) +desugar (PowerExpr expr1 expr2) = + (\x y -> makeApply "**" [x, y]) <$> desugar expr1 <*> desugar expr2 desugar (ArrayBoundsExpr expr) = ArrayBoundsExpr <$> desugar expr @@ -359,15 +330,12 @@ 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 $ stringToVarExpr (":::" ++ id) -desugar (MatcherExpr matcherInfo) = - MatcherExpr <$> desugarMatcherInfo matcherInfo +desugar (MatcherExpr patternDefs) = + MatcherExpr <$> mapM desugarPatternDef patternDefs desugar (PartialVarExpr n) = return $ PartialVarExpr n @@ -381,18 +349,18 @@ desugar (QuoteSymbolExpr expr) = QuoteSymbolExpr <$> desugar expr -desugar (WedgeExpr (ApplyExpr expr0 expr1)) = +desugar (WedgeApplyExpr expr0 expr1) = WedgeApplyExpr <$> desugar expr0 <*> desugar expr1 desugar expr = return expr -desugarIndex :: Index EgisonExpr -> DesugarM (Index EgisonExpr) +desugarIndex :: Index EgisonExpr -> EgisonM (Index EgisonExpr) desugarIndex (Superscript expr) = Superscript <$> desugar expr desugarIndex (Subscript expr) = Subscript <$> desugar expr desugarIndex (SupSubscript expr) = SupSubscript <$> desugar expr desugarIndex (Userscript expr) = Userscript <$> desugar expr -desugarPattern :: EgisonPattern -> DesugarM EgisonPattern +desugarPattern :: EgisonPattern -> EgisonM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern where collectNames :: [EgisonPattern] -> Set String @@ -419,7 +387,7 @@ makeBinding :: String -> BindingExpr makeBinding name = ([stringToVar name], HashExpr []) -desugarPattern' :: EgisonPattern -> DesugarM EgisonPattern +desugarPattern' :: EgisonPattern -> EgisonM EgisonPattern desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr desugarPattern' (PredPat expr) = PredPat <$> desugar expr desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern @@ -467,25 +435,23 @@ desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' pattern = return pattern -desugarLoopRange :: LoopRange -> DesugarM LoopRange +desugarLoopRange :: LoopRange -> EgisonM LoopRange desugarLoopRange (LoopRange sExpr eExpr pattern) = LoopRange <$> desugar sExpr <*> desugar eExpr <*> desugarPattern' pattern -desugarBindings :: [BindingExpr] -> DesugarM [BindingExpr] +desugarBindings :: [BindingExpr] -> EgisonM [BindingExpr] desugarBindings = mapM f where f (name, expr) = (name,) <$> desugar expr -desugarMatchClauses :: [MatchClause] -> DesugarM [MatchClause] +desugarMatchClauses :: [MatchClause] -> EgisonM [MatchClause] desugarMatchClauses = mapM f where f (pattern, expr) = (,) <$> desugarPattern pattern <*> desugar expr -desugarMatcherInfo :: MatcherInfo -> DesugarM MatcherInfo -desugarMatcherInfo = mapM f - where - f (pp, matcher, pds) = - (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds +desugarPatternDef :: PatternDef -> EgisonM PatternDef +desugarPatternDef (pp, matcher, pds) = + (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds -desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> DesugarM [(PrimitiveDataPattern, EgisonExpr)] +desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> EgisonM [(PrimitiveDataPattern, EgisonExpr)] desugarPrimitiveDataMatchClauses = mapM f where f (pd, expr) = (pd,) <$> desugar expr diff --git a/hs-src/Language/Egison/MathOutput.hs b/hs-src/Language/Egison/MathOutput.hs --- a/hs-src/Language/Egison/MathOutput.hs +++ b/hs-src/Language/Egison/MathOutput.hs @@ -3,71 +3,58 @@ Copyright : Satoshi Egi Licence : MIT -This module provides utility functions. +This module provides translation from mathematical Egison expression into +other languages / format of other computer algebra systems. -} -module Language.Egison.MathOutput ( changeOutputInLang ) where +module Language.Egison.MathOutput + ( changeOutputInLang + ) where +import Data.List (intercalate) + import Text.ParserCombinators.Parsec hiding (spaces) changeOutputInLang :: String -> String -> String -changeOutputInLang "haskell" input = mathExprToHaskell input -changeOutputInLang "asciimath" input = mathExprToAsciiMath input -changeOutputInLang "latex" input = mathExprToLatex input -changeOutputInLang "mathematica" input = mathExprToMathematica input -changeOutputInLang "maxima" input = mathExprToMaxima input -changeOutputInLang _ input = input - -mathExprToHaskell :: String -> String -mathExprToHaskell input = case parse parseExpr "math-expr" input of - Left err -> input - Right val -> "#haskell|" ++ show val ++ "|#" - -mathExprToAsciiMath :: String -> String -mathExprToAsciiMath input = case parse parseExpr "math-expr" input of - Left err -> input - Right val -> case showMathExprAsciiMath val of - "undefined" -> "undefined" - output -> "#asciimath|" ++ output ++ "|#" - -mathExprToLatex :: String -> String -mathExprToLatex input = case parse parseExpr "math-expr" input of - Left err -> input - Right val -> case showMathExprLatex val of - "undefined" -> "undefined" - output -> "#latex|" ++ output ++ "|#" +changeOutputInLang lang input = + -- 'lang' is either "asciimath", "latex", "mathematica" or "maxima" + -- Other invalid options are rejected in Interpreter/egison.hs + case parse parseExpr "math-expr" input of + Left err -> input + Right val -> case showMathExpr lang val of + "undefined" -> "undefined" + output -> "#" ++ lang ++ "|" ++ output ++ "|#" -mathExprToMathematica :: String -> String -mathExprToMathematica input = case parse parseExpr "math-expr" input of - Left err -> input - Right val -> case showMathExprMathematica val of - "undefined" -> "undefined" - output -> "#mathematica|" ++ output ++ "|#" +showMathExpr :: String -> MathExpr -> String +showMathExpr "asciimath" = showMathExprAsciiMath +showMathExpr "latex" = showMathExprLatex +showMathExpr "mathematica" = showMathExprMathematica +showMathExpr "maxima" = showMathExprMaxima +showMathExpr "haskell" = show -mathExprToMaxima :: String -> String -mathExprToMaxima input = case parse parseExpr "math-expr" input of - Left err -> input - Right val -> case showMathExprMaxima val of - "undefined" -> "undefined" - output -> "#maxima|" ++ output ++ "|#" +data MathExpr + = Atom String [MathIndex] + | NegativeAtom String + | Plus [MathExpr] + | Multiply [MathExpr] + | Power MathExpr MathExpr + | Func MathExpr [MathExpr] + | Tensor [MathExpr] [MathIndex] + | Tuple [MathExpr] + | Collection [MathExpr] + | Exp MathExpr + | Quote MathExpr + | Partial MathExpr [MathExpr] + deriving (Eq, Show) -data MathExpr = Atom String [MathIndex] - | NegativeAtom String - | Plus [MathExpr] - | Multiply [MathExpr] - | Power MathExpr MathExpr - | Func MathExpr [MathExpr] - | Tensor [MathExpr] [MathIndex] - | Tuple [MathExpr] - | Collection [MathExpr] - | Exp MathExpr - | Quote MathExpr - | Partial MathExpr [MathExpr] - deriving (Eq, Show) +data MathIndex + = Super MathExpr + | Sub MathExpr + deriving (Eq, Show) -data MathIndex = Super MathExpr - | Sub MathExpr - deriving (Eq, Show) +isSub :: MathIndex -> Bool +isSub (Sub _) = True +isSub _ = False -- -- Show (AsciiMath) @@ -103,22 +90,16 @@ showMathExprAsciiMath (Collection lvs) = "{" ++ showMathExprAsciiMathArg lvs ++ "}" showMathExprAsciiMath (Exp x) = "e^(" ++ showMathExprAsciiMath x ++ ")" -isSub :: MathIndex -> Bool -isSub (Sub _) = True -isSub _ = False - showMathExprAsciiMath' :: MathExpr -> String showMathExprAsciiMath' (Plus lvs) = "(" ++ showMathExprAsciiMath (Plus lvs) ++ ")" showMathExprAsciiMath' val = showMathExprAsciiMath val showMathExprAsciiMathArg :: [MathExpr] -> String -showMathExprAsciiMathArg [] = "" -showMathExprAsciiMathArg [a] = showMathExprAsciiMath a -showMathExprAsciiMathArg lvs = showMathExprAsciiMath (head lvs) ++ ", " ++ showMathExprAsciiMathArg (tail lvs) +showMathExprAsciiMathArg exprs = intercalate ", " $ map showMathExprAsciiMath exprs showMathExprAsciiMathIndices :: [MathIndex] -> String -showMathExprAsciiMathIndices [a] = showMathIndexAsciiMath a -showMathExprAsciiMathIndices lvs = showMathIndexAsciiMath (head lvs) ++ showMathExprAsciiMathIndices (tail lvs) +showMathExprAsciiMathIndices [] = error "unreachable" +showMathExprAsciiMathIndices lvs = concatMap showMathIndexAsciiMath lvs showMathIndexAsciiMath :: MathIndex -> String showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a @@ -174,9 +155,7 @@ showMathExprLatex' x = showMathExprLatex x showMathExprLatexArg :: [MathExpr] -> String -> String -showMathExprLatexArg [] _ = "" -showMathExprLatexArg [a] _ = showMathExprLatex a -showMathExprLatexArg lvs s = showMathExprLatex (head lvs) ++ s ++ showMathExprLatexArg (tail lvs) s +showMathExprLatexArg exprs sep = intercalate sep $ map showMathExprLatex exprs showMathExprLatexSuper :: MathIndex -> String showMathExprLatexSuper (Super (Atom "#" [])) = "\\#" @@ -242,16 +221,14 @@ showMathExprMathematica' x = showMathExprMathematica x showMathExprsMathematica :: String -> [MathExpr] -> String -showMathExprsMathematica _ [] = "" -showMathExprsMathematica _ [a] = showMathExprMathematica a -showMathExprsMathematica s lvs = showMathExprMathematica (head lvs) ++ s ++ showMathExprsMathematica s (tail lvs) +showMathExprsMathematica sep exprs = intercalate sep $ map showMathExprMathematica exprs showMathExprMathematicaArg :: [MathExpr] -> String -showMathExprMathematicaArg xs = showMathExprsMathematica ", " xs +showMathExprMathematicaArg = showMathExprsMathematica ", " showMathExprMathematicaIndices :: [MathIndex] -> String -showMathExprMathematicaIndices [a] = showMathIndexMathematica a -showMathExprMathematicaIndices lvs = showMathIndexMathematica (head lvs) ++ showMathExprMathematicaIndices (tail lvs) +showMathExprMathematicaIndices [] = error "unreachable" +showMathExprMathematicaIndices lvs = concatMap showMathIndexMathematica lvs showMathIndexMathematica :: MathIndex -> String showMathIndexMathematica (Super a) = showMathExprMathematica a diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -57,10 +57,10 @@ readTopExpr = either throwError desugarTopExpr . parseTopExpr readExprs :: String -> EgisonM [EgisonExpr] -readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs +readExprs = either throwError (mapM desugarExpr) . parseExprs readExpr :: String -> EgisonM EgisonExpr -readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr +readExpr = either throwError desugarExpr . parseExpr parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] parseTopExprs = doParse $ do @@ -167,29 +167,21 @@ loadExpr = keywordLoad >> Load <$> stringLiteral expr :: Parser EgisonExpr -expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr' +expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr expr1 <- option expr0 $ try (string "..." >> IndexedExpr False expr0 <$> parseindex) <|> IndexedExpr True expr0 <$> parseindex option expr1 $ PowerExpr expr1 <$> try (char '^' >> expr')) where parseindex :: Parser [Index EgisonExpr] - parseindex = many1 (try (do - char '_' - e1 <- expr' - string "..._" - MultiSubscript e1 <$> expr') - <|> try (do - char '~' - e1 <- expr' - string "...~" - MultiSuperscript e1 <$> expr') - <|> try (Subscript <$> (char '_' >> expr')) - <|> try (Superscript <$> (char '~' >> expr')) - <|> try (SupSubscript <$> (string "~_" >> expr')) - <|> try (Userscript <$> (char '|' >> expr'))) + parseindex = many1 (try (MultiSubscript <$> (char '_' >> expr') <*> (string "..._" >> expr')) + <|> try (MultiSuperscript <$> (char '~' >> expr') <*> (string "...~" >> expr')) + <|> try (Subscript <$> (char '_' >> expr')) + <|> try (Superscript <$> (char '~' >> expr')) + <|> try (SupSubscript <$> (string "~_" >> expr')) + <|> try (Userscript <$> (char '|' >> expr'))) -quoteExpr' :: Parser EgisonExpr -quoteExpr' = char '\'' >> QuoteExpr <$> expr' +quoteExpr :: Parser EgisonExpr +quoteExpr = char '\'' >> QuoteExpr <$> expr' expr' :: Parser EgisonExpr expr' = try partialExpr @@ -203,7 +195,6 @@ <|> try tupleExpr <|> try hashExpr <|> collectionExpr --- <|> quoteExpr <|> quoteSymbolExpr <|> wedgeExpr <|> parens (ifExpr @@ -287,11 +278,11 @@ pairExpr :: Parser (EgisonExpr, EgisonExpr) pairExpr = brackets $ (,) <$> expr <*> expr -quoteExpr :: Parser EgisonExpr -quoteExpr = char '\'' >> QuoteExpr <$> expr - wedgeExpr :: Parser EgisonExpr -wedgeExpr = char '!' >> WedgeExpr <$> expr +wedgeExpr = do + e <- char '!' >> expr + case e of + ApplyExpr e1 e2 -> return $ WedgeApplyExpr e1 e2 functionWithArgExpr :: Parser EgisonExpr functionWithArgExpr = keywordFunction >> FunctionExpr <$> between lp rp (sepEndBy expr whiteSpace) @@ -332,10 +323,10 @@ matcherExpr :: Parser EgisonExpr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses -ppMatchClauses :: Parser MatcherInfo +ppMatchClauses :: Parser [PatternDef] ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace -ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) +ppMatchClause :: Parser PatternDef ppMatchClause = brackets $ (,,) <$> ppPattern <*> expr <*> pdMatchClauses pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)] @@ -706,11 +697,7 @@ boolExpr = BoolExpr <$> boolLiteral floatExpr :: Parser EgisonExpr -floatExpr = do - (x,y) <- try ((,) <$> floatLiteral <*> (sign' <*> positiveFloatLiteral) <* char 'i') - <|> try ((0,) <$> floatLiteral <* char 'i') - <|> try ((, 0) <$> floatLiteral) - return $ FloatExpr x y +floatExpr = FloatExpr <$> positiveFloatLiteral integerExpr :: Parser EgisonExpr integerExpr = IntegerExpr <$> integerLiteral' @@ -729,9 +716,6 @@ let m = read mStr let l = m % (10 ^ fromIntegral (length mStr)) return (fromRational (fromIntegral n + l) :: Double) - -floatLiteral :: Parser Double -floatLiteral = sign <*> positiveFloatLiteral -- -- Tokens diff --git a/hs-src/Language/Egison/ParserNonS.hs b/hs-src/Language/Egison/ParserNonS.hs --- a/hs-src/Language/Egison/ParserNonS.hs +++ b/hs-src/Language/Egison/ParserNonS.hs @@ -1,953 +1,805 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} - -{- | -Module : Language.Egison.ParserNonS -Copyright : Satoshi Egi -Licence : MIT - -This module provide Egison parser. --} - -module Language.Egison.ParserNonS - ( - -- * 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.Identity (Identity, unless) -import Prelude hiding (mapM) - -import System.Directory (doesFileExist, getHomeDirectory) - -import Data.Char (isLower, isUpper, toLower) -import Data.Either -import Data.Functor (($>)) -import Data.List (intercalate) -import Data.List.Split (split, splitOn, startsWithOneOf) -import Data.Ratio -import Data.Traversable (mapM) - -import Text.Parsec -import Text.Parsec.Expr -import Text.Parsec.String -import qualified Text.Parsec.Token as P - -import qualified Data.Text as T - -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 $ do - ret <- whiteSpace >> endBy topExpr whiteSpace - eof - return ret - -parseTopExpr :: String -> Either EgisonError EgisonTopExpr -parseTopExpr = doParse $ do - ret <- whiteSpace >> topExpr - whiteSpace >> eof - return ret - -parseExprs :: String -> Either EgisonError [EgisonExpr] -parseExprs = doParse $ do - ret <- whiteSpace >> endBy expr whiteSpace - eof - return ret - -parseExpr :: String -> Either EgisonError EgisonExpr -parseExpr = doParse $ do - ret <- whiteSpace >> expr - whiteSpace >> eof - return ret - --- |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 --- - -doParse :: Parser a -> String -> Either EgisonError a -doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input - where - fromParsecError :: ParseError -> EgisonError - fromParsecError = Parser . show - -doParse' :: Parser a -> String -> a -doParse' p input = case doParse p input of - Right x -> x - --- --- Expressions --- - -topExpr :: Parser EgisonTopExpr -topExpr = try defineExpr - <|> try (Test <$> expr) - <|> testExpr - <|> loadFileExpr - <|> loadExpr - "top-level expression" - -defineExpr :: Parser EgisonTopExpr -defineExpr = try (Define <$ keywordDefine <*> identVar <*> (LambdaExpr <$> parens argNames' <* inSpaces (reservedOp "=") <* notFollowedBy (string "=") <*> expr)) - <|> try (Define <$> identVar <* inSpaces (reservedOp "=") <* notFollowedBy (string "=") <*> expr) - <|> try (do (VarWithIndices name is) <- identVarWithIndices - inSpaces $ reservedOp "=" >> notFollowedBy (string "=") - Define (Var name (map f is)) . WithSymbolsExpr (map g is) . TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) <$> expr) - where - argNames' :: Parser [Arg] - argNames' = sepEndBy argName' comma - argName' :: Parser Arg - argName' = try (ScalarArg <$> ident) - <|> try (InvertedScalarArg <$> (char '*' >> ident)) - <|> try (TensorArg <$> (char '%' >> ident)) - f (Superscript _) = Superscript () - f (Subscript _) = Subscript () - f (SupSubscript _) = SupSubscript () - g (Superscript i) = i - g (Subscript i) = i - g (SupSubscript i) = i - -testExpr :: Parser EgisonTopExpr -testExpr = keywordTest >> Test <$> parens expr - -loadFileExpr :: Parser EgisonTopExpr -loadFileExpr = keywordLoadFile >> LoadFile <$> parens stringLiteral - -loadExpr :: Parser EgisonTopExpr -loadExpr = keywordLoad >> Load <$> parens stringLiteral - -expr :: Parser EgisonExpr -expr = (try applyInfixExpr - <|> try exprWithSymbol - <|> try (buildExpressionParser table arg) - <|> try ifExpr - <|> try term) - "expression" - where - arg = (char '$' *> notFollowedBy varExpr *> (LambdaArgExpr <$> option "" index)) - <|> term - index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit - table = [ [unary "not" AssocRight] - , [binary "^" "**" AssocLeft] - , [unary "-" AssocLeft] - , [binary "*" "*" AssocLeft, binary "/" "/" AssocLeft, binary "." "." AssocLeft] - , [binary "+" "+" AssocLeft, binary "-" "-" AssocLeft, binary "%" "remainder" AssocLeft] - , [binary "==" "eq?" AssocLeft, binary "<=" "lte?" AssocLeft, binary "<" "lt?" AssocLeft, binary ">=" "gte?" AssocLeft, binary ">" "gt?" AssocLeft] - , [binary ":" "cons" AssocLeft, binary ".." "between" AssocLeft] - , [binary "&&" "and" AssocLeft, binary "||" "or" AssocLeft] - , [binary "++" "join" AssocRight] - ] - 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 (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) - -inSpaces1 :: Parser a -> Parser () -inSpaces1 p = skipMany (space <|> newline) >> p >> skipMany1 (space <|> newline) - -exprWithSymbol :: Parser EgisonExpr -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 -term = P.lexeme lexer - (do term0 <- term' - option term0 $ try (IndexedExpr False term0 <$ string "..." <*> parseindex - <|> IndexedExpr True term0 <$> parseindex)) - where - parseindex :: Parser [Index EgisonExpr] - parseindex = many1 $ try (MultiSubscript <$ char '_' <*> term' <* string "..._" <*> term') - <|> try (MultiSuperscript <$ char '~' <*> term' <* string "...~" <*> term') - <|> try (char '_' >> Subscript <$> term') - <|> try (char '~' >> Superscript <$> term') - <|> try (string "~_" >> SupSubscript <$> term') - <|> try (char '|' >> Userscript <$> term') - -term' :: Parser EgisonExpr -term' = matchExpr - <|> matchAllExpr - <|> matchAllDFSExpr - <|> matchLambdaExpr - <|> matchAllLambdaExpr - <|> matcherExpr - <|> functionWithArgExpr - <|> userrefsExpr - <|> algebraicDataMatcherExpr - <|> try applyExpr - <|> cApplyExpr - <|> try partialExpr - <|> try partialVarExpr - <|> try constantExpr - <|> try freshVarExpr - <|> try lambdaExpr - <|> try cambdaExpr - <|> try withSymbolsExpr - <|> try varExpr - <|> try vectorExpr - <|> try tupleExpr - <|> try hashExpr - <|> try collectionExpr - <|> inductiveDataExpr - <|> try doExpr - <|> generateTensorExpr - <|> tensorExpr - <|> letExpr - <|> letRecExpr - <|> letStarExpr - <|> patternFunctionExpr - <|> quoteExpr - <|> quoteSymbolExpr - <|> tensorContractExpr - <|> subrefsExpr - <|> suprefsExpr - <|> macroExpr - <|> ioExpr - <|> seqExpr - <|> memoizedLambdaExpr - <|> procedureExpr - <|> wedgeExpr - <|> parens expr - "simple expression" - -varExpr :: Parser EgisonExpr -varExpr = VarExpr <$> identVarWithoutIndex - -freshVarExpr :: Parser EgisonExpr -freshVarExpr = char '#' >> return FreshVarExpr - -inductiveDataExpr :: Parser EgisonExpr -inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy term whiteSpace - -tupleExpr :: Parser EgisonExpr -tupleExpr = parens $ TupleExpr <$> sepEndBy expr comma - -collectionExpr :: Parser EgisonExpr -collectionExpr = brackets (CollectionExpr <$> sepEndBy innerExpr comma) - <|> braces (CollectionExpr <$> sepEndBy innerExpr comma) - where - innerExpr :: Parser InnerExpr - innerExpr = (char '@' >> SubCollectionExpr <$> expr) - <|> ElementExpr <$> expr - -vectorExpr :: Parser EgisonExpr -vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr comma - where - lp = P.lexeme lexer (string "[|") - rp = string "|]" - -hashExpr :: Parser EgisonExpr -hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr comma - where - lp = P.lexeme lexer (string "{|") - rp = string "|}" - pairExpr :: Parser (EgisonExpr, EgisonExpr) - pairExpr = brackets $ (,) <$> expr <* comma <*> expr - -quoteExpr :: Parser EgisonExpr -quoteExpr = char '\'' >> QuoteExpr <$> expr - -wedgeExpr :: Parser EgisonExpr -wedgeExpr = char '!' >> WedgeExpr <$> expr - -functionWithArgExpr :: Parser EgisonExpr -functionWithArgExpr = keywordFunction >> FunctionExpr <$> parens (sepEndBy expr comma) - -quoteSymbolExpr :: Parser EgisonExpr -quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr - -matchAllExpr :: Parser EgisonExpr -matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* keywordAs <*> expr <*> matchClauses - -matchAllDFSExpr :: Parser EgisonExpr -matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <* keywordAs <*> expr <*> matchClauses - -matchExpr :: Parser EgisonExpr -matchExpr = keywordMatch >> MatchExpr <$> expr <* keywordAs <*> expr <*> matchClauses - -matchLambdaExpr :: Parser EgisonExpr -matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$ keywordAs <*> expr <*> matchClauses - -matchAllLambdaExpr :: Parser EgisonExpr -matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$ keywordAs <*> expr <*> matchClauses - -matchClauses :: Parser [MatchClause] -matchClauses = many1 matchClause - -matchClause :: Parser MatchClause -matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* reservedOp "->" <*> expr - -matcherExpr :: Parser EgisonExpr -matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses - -ppMatchClauses :: Parser MatcherInfo -ppMatchClauses = many1 ppMatchClause - -ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) -ppMatchClause = inSpaces (string "|") >> (,,) <$> ppPattern <* keywordAs <*> expr <* reservedOp "->" <*> pdMatchClauses - -pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)] -pdMatchClauses = many1 pdMatchClause - -pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr) -pdMatchClause = try $ inSpaces (string "|") >> (,) <$> pdPattern <* reservedOp "->" <*> expr - -ppPattern :: Parser PrimitivePatPattern -ppPattern = P.lexeme lexer (ppWildCard - <|> try ppValuePat - <|> ppPatVar - <|> ppInductivePat - "primitive-pattren-pattern") - -ppWildCard :: Parser PrimitivePatPattern -ppWildCard = reservedOp "_" $> PPWildCard - -ppPatVar :: Parser PrimitivePatPattern -ppPatVar = reservedOp "$" $> PPPatVar - -ppValuePat :: Parser PrimitivePatPattern -ppValuePat = reservedOp "$" >> PPValuePat <$> ident - -ppInductivePat :: Parser PrimitivePatPattern -ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace) - -pdPattern :: Parser PrimitiveDataPattern -pdPattern = P.lexeme lexer pdPattern' - -pdPattern' :: Parser PrimitiveDataPattern -pdPattern' = reservedOp "_" $> PDWildCard - <|> (char '$' >> PDPatVar <$> ident) - <|> brackets ((PDConsPat <$> pdPattern <* comma <*> (char '@' *> pdPattern)) - <|> (PDSnocPat <$> (char '@' *> pdPattern) <* comma <*> pdPattern) - <|> pure PDEmptyPat) - <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace) - <|> parens (PDTuplePat <$> sepEndBy pdPattern comma) - <|> PDConstantPat <$> constantExpr - "primitive-data-pattern" - -ifExpr :: Parser EgisonExpr -ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr - -lambdaExpr :: Parser EgisonExpr -lambdaExpr = LambdaExpr <$> argNames <* reservedOp "->" <*> expr - -memoizedLambdaExpr :: Parser EgisonExpr -memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <* reservedOp "->" <*> expr - -memoizeFrame :: Parser [(EgisonExpr, EgisonExpr, EgisonExpr)] -memoizeFrame = braces $ sepEndBy memoizeBinding whiteSpace - -memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr) -memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr - -cambdaExpr :: Parser EgisonExpr -cambdaExpr = keywordCambda >> char '$' >> CambdaExpr <$> ident <* reservedOp "->" <*> expr - -procedureExpr :: Parser EgisonExpr -procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <* reservedOp "->" <*> expr - -macroExpr :: Parser EgisonExpr -macroExpr = keywordMacro >> MacroExpr <$> varNames <* reservedOp "->" <*> expr - -patternFunctionExpr :: Parser EgisonExpr -patternFunctionExpr = keywordPatternFunction >> parens (PatternFunctionExpr <$> brackets (sepEndBy ident comma) <* comma <*> pattern) - -letRecExpr :: Parser EgisonExpr -letRecExpr = keywordLetRec >> LetRecExpr <$> bindings <* keywordLetIn <*> expr - -letExpr :: Parser EgisonExpr -letExpr = keywordLet >> LetExpr <$> bindings <* keywordLetIn <*> expr - -letStarExpr :: Parser EgisonExpr -letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <* keywordLetIn <*> expr - -withSymbolsExpr :: Parser EgisonExpr -withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident comma) <*> expr - -doExpr :: Parser EgisonExpr -doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (stringToVarExpr "return") (TupleExpr [])) expr - -statements :: Parser [BindingExpr] -statements = braces $ sepEndBy statement comma - -statement :: Parser BindingExpr -statement = try binding - <|> (([],) <$> expr) - -bindings :: Parser [BindingExpr] -bindings = sepEndBy binding comma - -binding :: Parser BindingExpr -binding = (,) <$> varNames' <* inSpaces (string "=") <*> expr - -varNames :: Parser [String] -varNames = sepEndBy (char '$' >> ident) whiteSpace - -varNames' :: Parser [Var] -varNames' = return <$> identVar - <|> parens (sepEndBy identVar comma) - -argNames :: Parser [Arg] -argNames = sepEndBy argName whiteSpace - -argName :: Parser Arg -argName = try (ScalarArg <$> (char '$' >> ident)) - <|> try (InvertedScalarArg <$> (string "*$" >> ident)) - <|> try (TensorArg <$> (char '%' >> ident)) - -ioExpr :: Parser EgisonExpr -ioExpr = keywordIo >> parens (IoExpr <$> expr) - -seqExpr :: Parser EgisonExpr -seqExpr = keywordSeq >> parens (SeqExpr <$> expr <* comma <*> expr) - -cApplyExpr :: Parser EgisonExpr -cApplyExpr = keywordCApply >> parens (CApplyExpr <$> expr <* comma <*> expr) - -applyExpr :: Parser EgisonExpr -applyExpr = (keywordApply >> parens (ApplyExpr <$> expr <* comma <*> expr)) - <|> try applyExpr' - -applyExpr' :: Parser EgisonExpr -applyExpr' = do - func <- try varExpr <|> try partialExpr <|> try partialVarExpr <|> parens expr - applyExpr'' func - -applyExpr'' :: EgisonExpr -> Parser EgisonExpr -applyExpr'' func = do - argslist <- many1 $ parens args - return $ foldl makeApply func argslist - where - args = sepEndBy arg comma - arg = try expr - <|> char '$' *> (LambdaArgExpr <$> option "" index) - index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit - -applyInfixExpr :: Parser EgisonExpr -applyInfixExpr = do - arg1 <- arg - spaces - func <- char '`' *> varExpr <* char '`' - spaces - arg2 <- arg - return $ makeApply func [arg1, arg2] - where - arg = try term - <|> char '$' *> (LambdaArgExpr <$> option "" index) - index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit - -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 = length 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 - -partialExpr :: Parser EgisonExpr -partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> (try (parens expr) <|> expr)) - where - index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit - -partialVarExpr :: Parser EgisonExpr -partialVarExpr = char '%' >> PartialVarExpr <$> integerLiteral - -algebraicDataMatcherExpr :: Parser EgisonExpr -algebraicDataMatcherExpr = keywordAlgebraicDataMatcher - >> AlgebraicDataMatcherExpr <$> parens (sepEndBy1 inductivePat' comma) - where - inductivePat' :: Parser (String, [EgisonExpr]) - inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace - -generateTensorExpr :: Parser EgisonExpr -generateTensorExpr = keywordGenerateTensor >> parens (GenerateTensorExpr <$> expr <* comma <*> expr) - -tensorExpr :: Parser EgisonExpr -tensorExpr = keywordTensor >> parens (TensorExpr <$> expr <* comma <*> expr <*> option (CollectionExpr []) (comma *> expr) <*> option (CollectionExpr []) (comma *> expr)) - -tensorContractExpr :: Parser EgisonExpr -tensorContractExpr = keywordTensorContract >> parens (TensorContractExpr <$> expr <* comma <*> expr) - -subrefsExpr :: Parser EgisonExpr -subrefsExpr = (keywordSubrefs >> parens (SubrefsExpr False <$> expr <* comma <*> expr)) - <|> (keywordSubrefsNew >> parens (SubrefsExpr True <$> expr <* comma <*> expr)) - -suprefsExpr :: Parser EgisonExpr -suprefsExpr = (keywordSuprefs >> SuprefsExpr False <$> expr <*> expr) - <|> (keywordSuprefsNew >> SuprefsExpr True <$> expr <*> expr) - -userrefsExpr :: Parser EgisonExpr -userrefsExpr = (do keywordUserrefs - xs <- parens $ sepEndBy expr comma - case xs of - [x, y] -> return $ UserrefsExpr False x y - _ -> unexpected "number of arguments (expected 2)") - <|> (do keywordUserrefsNew - xs <- parens $ sepEndBy expr comma - case xs of - [x, y] -> return $ UserrefsExpr True x y - _ -> unexpected "number of arguments (expected 2)") - --- Patterns - -pattern :: Parser EgisonPattern -pattern = P.lexeme lexer - (try (buildExpressionParser table pattern') - <|> try pattern' - "expression") - - where - table = [ [unary "!" AssocRight, unary "not" AssocRight] - , [binary'' "^" PowerPat AssocLeft] - , [binary' "*" MultPat AssocRight, binary'' "/" DivPat AssocRight] - , [binary' "+" PlusPat AssocRight] - , [binary "<:>" "cons" AssocRight] - , [binary' "and" AndPat AssocLeft, binary' "or" OrPat AssocLeft] - , [binary "<++>" "join" AssocRight] - ] - unary op assoc = Prefix (try $ inSpaces (string op) >> return NotPat) - binary op name = Infix (try $ inSpaces (string op) >> return (\x y -> InductivePat name [x, y])) - binary' op epr = Infix (try $ inSpaces (string op) >> return (\x y -> epr [x, y])) - binary'' op epr = Infix (try $ inSpaces (string op) >> return epr) - -pattern' :: Parser EgisonPattern -pattern' = wildCard - <|> contPat - <|> try indexedPat - <|> patVar - <|> try loopPat - <|> try pApplyPat - <|> try dApplyPat - <|> try varPat - <|> valuePat - <|> predPat - <|> try tuplePat - <|> inductivePat - <|> letPat - <|> parens pattern - -pattern'' :: Parser EgisonPattern -pattern'' = wildCard - <|> patVar - <|> valuePat - -wildCard :: Parser EgisonPattern -wildCard = reservedOp "_" >> pure WildCard - -indexedPat :: Parser EgisonPattern -indexedPat = IndexedPat <$> (patVar <|> varPat) <*> many1 (try $ char '_' >> term') - -patVar :: Parser EgisonPattern -patVar = char '$' >> PatVar <$> identVarWithoutIndex - -varPat :: Parser EgisonPattern -varPat = char '\'' >> VarPat <$> ident - -valuePat :: Parser EgisonPattern -valuePat = ValuePat <$> expr - -predPat :: Parser EgisonPattern -predPat = char '?' >> PredPat <$> expr - -letPat :: Parser EgisonPattern -letPat = keywordLet >> LetPat <$> bindings <* keywordLetIn <*> pattern - -tuplePat :: Parser EgisonPattern -tuplePat = TuplePat <$> parens ((:) <$> pattern <* comma <*> sepEndBy1 pattern comma) - -inductivePat :: Parser EgisonPattern -inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace - -contPat :: Parser EgisonPattern -contPat = keywordCont >> pure ContPat - -pApplyPat :: Parser EgisonPattern -pApplyPat = PApplyPat <$> expr <*> brackets (sepEndBy pattern comma) - -dApplyPat :: Parser EgisonPattern -dApplyPat = DApplyPat <$> pattern'' <*> parens (sepEndBy pattern comma) - -loopPat :: Parser EgisonPattern -loopPat = keywordLoop >> parens (char '$' >> LoopPat <$> identVarWithoutIndex <*> (comma >> loopRange) <*> (comma >> pattern) <*> (comma >> option (NotPat WildCard) pattern)) - -loopRange :: Parser LoopRange -loopRange = parens (try (LoopRange <$> expr <* comma <*> expr <*> option WildCard (comma >> pattern)) - <|> (do s <- expr - comma - ep <- option WildCard pattern - return (LoopRange s (ApplyExpr (stringToVarExpr "from") (ApplyExpr (stringToVarExpr "-'") (TupleExpr [s, IntegerExpr 1]))) ep))) - --- Constants - -constantExpr :: Parser EgisonExpr -constantExpr = stringExpr - <|> boolExpr - <|> try charExpr - <|> try floatExpr - <|> try integerExpr - <|> (keywordSomething $> SomethingExpr) - <|> (keywordUndefined $> UndefinedExpr) - "constant" - -charExpr :: Parser EgisonExpr -charExpr = CharExpr <$> oneChar - -stringExpr :: Parser EgisonExpr -stringExpr = StringExpr . T.pack <$> stringLiteral - -boolExpr :: Parser EgisonExpr -boolExpr = BoolExpr <$> boolLiteral - -floatExpr :: Parser EgisonExpr -floatExpr = do - (x,y) <- try ((,) <$> floatLiteral <*> (sign' <*> positiveFloatLiteral) <* char 'i') - <|> try ((,) 0 <$> floatLiteral <* char 'i') - <|> try ((, 0) <$> floatLiteral) - return $ FloatExpr x y - -integerExpr :: Parser EgisonExpr -integerExpr = IntegerExpr <$> integerLiteral' - -integerLiteral' :: Parser Integer -integerLiteral' = sign <*> positiveIntegerLiteral - -positiveIntegerLiteral :: Parser Integer -positiveIntegerLiteral = read <$> many1 digit - -positiveFloatLiteral :: Parser Double -positiveFloatLiteral = do - n <- positiveIntegerLiteral - char '.' - mStr <- many1 digit - let m = read mStr - let l = m % (10 ^ fromIntegral (length mStr)) - return (fromRational (fromIntegral n + l) :: Double) - -floatLiteral :: Parser Double -floatLiteral = sign <*> positiveFloatLiteral - --- --- Tokens --- - -egisonDef :: P.GenLanguageDef String () Identity -egisonDef = - P.LanguageDef { P.commentStart = "#|" - , P.commentEnd = "|#" - , P.commentLine = ";" - , P.identStart = letter <|> symbol1 - , P.identLetter = letter <|> digit <|> symbol0 <|> symbol2 - , P.opStart = symbol1 - , P.opLetter = symbol0 <|> symbol1 - , P.reservedNames = reservedKeywords - , P.reservedOpNames = reservedOperators - , P.nestedComments = True - , P.caseSensitive = True } - -symbol0 = oneOf "/." -symbol1' = oneOf "∂∇" -symbol1 = symbol1' <|> oneOf "+-" -symbol2 = symbol1' <|> oneOf "'!?" - -lexer :: P.GenTokenParser String () Identity -lexer = P.makeTokenParser egisonDef - -reservedKeywords :: [String] -reservedKeywords = - [ "define" - , "set!" - , "test" - , "loadFile" - , "load" - , "if" - , "then" - , "else" - , "as" - , "seq" - , "apply" - , "capply" - , "lambda" - , "memoizedLambda" - , "cambda" - , "procedure" - , "macro" - , "patternFunction" - , "letrec" - , "let" - , "let*" - , "in" - , "withSymbols" - , "loop" - , "matchAll" - , "matchAllDFS" - , "matchAllLambda" - , "match" - , "matchLambda" - , "matcher" - , "do" - , "io" - , "something" - , "undefined" - , "algebraicDataMatcher" - , "generateTensor" - , "tensor" - , "contract" - , "subrefs" - , "subrefs!" - , "suprefs" - , "suprefs!" - , "userRefs" - , "userRefs!" - , "function"] - -reservedOperators :: [String] -reservedOperators = - [ "$" - , "_" - , "^" - , "&" - , "|*" - , "(" - , ")" - , "->" - , "`" - , "==" - , "=" --- , "'" --- , "~" --- , "!" --- , "," --- , "@" - , "..."] - -reserved :: String -> Parser () -reserved = P.reserved lexer - -reservedOp :: String -> Parser () -reservedOp = P.reservedOp lexer - -keywordDefine = reserved "def" -keywordSet = reserved "set!" -keywordTest = reserved "test" -keywordLoadFile = reserved "loadFile" -keywordLoad = reserved "load" -keywordIf = reserved "if" -keywordThen = reserved "then" -keywordElse = reserved "else" -keywordAs = reserved "as" -keywordSeq = reserved "seq" -keywordApply = reserved "apply" -keywordCApply = reserved "capply" -keywordLambda = reserved "lambda" -keywordMemoizedLambda = reserved "memoizedLambda" -keywordCambda = reserved "cambda" -keywordProcedure = reserved "procedure" -keywordMacro = reserved "macro" -keywordPatternFunction = reserved "patternFunction" -keywordLetRec = reserved "letrec" -keywordLet = reserved "let" -keywordLetStar = reserved "let*" -keywordLetIn = reserved "in" -keywordWithSymbols = reserved "withSymbols" -keywordLoop = reserved "loop" -keywordCont = reserved "..." -keywordMatchAll = reserved "matchAll" -keywordMatchAllDFS = reserved "matchAllDFS" -keywordMatchAllLambda = reserved "matchAllLambda" -keywordMatch = reserved "match" -keywordMatchLambda = reserved "matchLambda" -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" - -sign :: Num a => Parser (a -> a) -sign = (char '-' >> return negate) - <|> (char '+' >> return id) - <|> return id - -sign' :: Num a => Parser (a -> a) -sign' = (char '-' >> return negate) - <|> (char '+' >> return id) - -integerLiteral :: Parser Integer -integerLiteral = sign <*> P.natural lexer - -stringLiteral :: Parser String -stringLiteral = P.stringLiteral lexer - -charLiteral :: Parser Char -charLiteral = P.charLiteral lexer - -oneChar :: Parser Char -oneChar = do - string "c#" - x <- (char '\\' >> anyChar >>= (\x -> return ['\\', x])) <|> (anyChar >>= (\x -> return [x])) - return $ doParse' charLiteral $ "'" ++ x ++ "'" - -boolLiteral :: Parser Bool -boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False) - -whiteSpace :: Parser () -whiteSpace = P.whiteSpace lexer - -parens :: Parser a -> Parser a -parens = P.parens lexer - -brackets :: Parser a -> Parser a -brackets = P.brackets lexer - -braces :: Parser a -> Parser a -braces = P.braces lexer - -angles :: Parser a -> Parser a -angles = P.angles lexer - -colon :: Parser String -colon = P.colon lexer - -comma :: Parser String -comma = P.comma lexer - -dot :: Parser String -dot = P.dot lexer - -ident :: Parser String -ident = do - idt <- P.identifier lexer - let (f, s) = splitLast idt '.' - case s of - [] -> return f - x:xs | isLower x -> return $ f ++ map toLower (intercalate "-" $ split (startsWithOneOf ['A'..'Z']) s) - | otherwise -> return $ f ++ [x] ++ map toLower (intercalate "-" $ split (startsWithOneOf ['A'..'Z']) xs) - where - splitLast list elem = let (f, s) = span (/= elem) $ reverse list - in (reverse s, reverse f) - -identVar :: Parser Var -identVar = P.lexeme lexer (do - name <- ident - is <- many indexType - return $ Var (splitOn "." name) is) - -identVarWithoutIndex :: Parser Var -identVarWithoutIndex = stringToVar <$> ident - -identVarWithIndices :: Parser VarWithIndices -identVarWithIndices = P.lexeme lexer (do - name <- ident - is <- many indexForVar - return $ VarWithIndices (splitOn "." name) is) - -indexForVar :: Parser (Index String) -indexForVar = try (char '~' >> Superscript <$> ident) - <|> try (char '_' >> Subscript <$> ident) - -indexType :: Parser (Index ()) -indexType = try (char '~' >> return (Superscript ())) - <|> try (char '_' >> return (Subscript ())) - -upperName :: Parser String -upperName = P.lexeme lexer upperName' - -upperName' :: Parser String -upperName' = (:) <$> upper <*> option "" ident - where - upper :: Parser Char - upper = satisfy isUpper - -lowerName :: Parser String -lowerName = P.lexeme lexer lowerName' - -lowerName' :: Parser String -lowerName' = (:) <$> lower <*> option "" ident - where - lower :: Parser Char - lower = satisfy isLower +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} + +{- | +Module : Language.Egison.ParserNonS +Copyright : Satoshi Egi +Licence : MIT + +This module provides the new parser of Egison. +-} + +module Language.Egison.ParserNonS + ( + -- * 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 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 = either throwError (mapM desugarExpr) . parseExprs + +readExpr :: String -> EgisonM EgisonExpr +readExpr = either throwError desugarExpr . 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 + | IllFormedDefine + 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) ++ "]" + showErrorComponent IllFormedDefine = + "Ill-formed definition syntax." + + +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 + -- TODO: Throw IllFormedDefine in pattern match failure. + -- first 2 cases are the most common ones + 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) + convertToDefine e@(BinaryOpExpr op _ _) body + | repr op == "*" || repr op == "%" = + case exprToArgs e of + ScalarArg var : args -> Define (Var [var] []) (LambdaExpr args body) + + exprToArg :: EgisonExpr -> Arg + exprToArg (VarExpr (Var [x] [])) = ScalarArg x + + exprToArgs :: EgisonExpr -> [Arg] + exprToArgs (VarExpr (Var [x] [])) = [ScalarArg x] + exprToArgs (ApplyExpr func (TupleExpr args)) = + exprToArgs func ++ map exprToArg args + exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "*" = + case exprToArgs rhs of + ScalarArg x : xs -> exprToArgs lhs ++ InvertedScalarArg x : xs + exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "%" = + case exprToArgs rhs of + ScalarArg x : xs -> exprToArgs lhs ++ TensorArg x : xs + +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 = ctor <$> (keyword >> expr) + <*> (keywordAs >> expr) + <*> (keywordWith >> matchClauses1) + +-- Parse more than 1 match clauses. +matchClauses1 :: Parser [MatchClause] +matchClauses1 = do + pos <- L.indentLevel + -- If the first bar '|' is missing, then it is expected to have only one match clause. + (lookAhead (symbol "|") >> some (matchClause pos)) <|> (:[]) <$> matchClauseWithoutBar + where + matchClauseWithoutBar :: Parser MatchClause + matchClauseWithoutBar = (,) <$> pattern <*> (symbol "->" >> expr) + + matchClause :: Pos -> Parser MatchClause + matchClause pos = (,) <$> (L.indentGuard sc EQ pos >> symbol "|" >> 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 + -- TODO(momohatt): Take associativity of operands into account + 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 = FloatExpr <$> try positiveFloatLiteral + <|> 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 + +pdPattern :: Parser PrimitiveDataPattern +pdPattern = PDInductivePat <$> upperId <*> many pdAtom + <|> PDSnocPat <$> (symbol "snoc" >> pdAtom) <*> pdAtom + <|> makeExprParser pdAtom table + "primitive data pattern" + where + table :: [[Operator Parser PrimitiveDataPattern]] + table = + [ [ InfixR (PDConsPat <$ symbol ":") ] + ] + pdAtom :: Parser PrimitiveDataPattern + pdAtom = PDWildCard <$ symbol "_" + <|> PDPatVar <$> (symbol "$" >> lowerId) + <|> PDConstantPat <$> constantExpr + <|> PDEmptyPat <$ (symbol "[" >> symbol "]") + <|> 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" + +positiveFloatLiteral :: Parser Double +positiveFloatLiteral = lexeme L.float + "unsigned 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 identChar) + +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 "%^&*-+\\|:<>.?/'" + +-- Characters that consist identifiers +identChar :: Parser Char +identChar = alphaNumChar <|> 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 identChar + 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" +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" + , "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) diff --git a/hs-src/Language/Egison/ParserNonS2.hs b/hs-src/Language/Egison/ParserNonS2.hs deleted file mode 100644 --- a/hs-src/Language/Egison/ParserNonS2.hs +++ /dev/null @@ -1,783 +0,0 @@ -{-# 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) diff --git a/hs-src/Language/Egison/Pretty.hs b/hs-src/Language/Egison/Pretty.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Pretty.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances #-} + +{- | +Module : Language.Egison.PrettyPrint +Copyright : Satoshi Egi +Licence : MIT + +This module contains pretty printing for Egison syntax +-} + +module Language.Egison.Pretty + ( prettyTopExprs + ) where + +import Data.Text.Prettyprint.Doc + +import Language.Egison.Types + +-- +-- Pretty printing for Non-S syntax +-- + +prettyTopExprs :: [EgisonTopExpr] -> Doc [EgisonTopExpr] +prettyTopExprs exprs = vsep $ punctuate line (map pretty exprs) + +instance Pretty EgisonTopExpr where + pretty (Define x (LambdaExpr args body)) = + pretty x <+> hsep (map pretty args) <+> equals <> softline <> pretty body + pretty (Define x expr) = pretty x <+> equals <> nest 2 (softline <> pretty expr) + pretty (Test expr) = pretty expr + +instance Pretty EgisonExpr where + pretty (CharExpr x) = squote <> pretty x <> squote + pretty (StringExpr x) = dquote <> pretty x <> dquote + pretty (BoolExpr x) = pretty x + pretty (IntegerExpr x) = pretty x + pretty (FloatExpr x) = pretty x + pretty (VarExpr x) = pretty x + + pretty (InductiveDataExpr c xs) = nest 2 (pretty c <+> fillSep (map pretty xs)) + + pretty (TupleExpr xs) = tupled (map pretty xs) + pretty (CollectionExpr xs) = list (map pretty xs) + pretty (ArrayExpr xs) = listoid "(|" "|)" (map pretty xs) + pretty (HashExpr xs) = listoid "{|" "|}" (map (\(x, y) -> list [pretty x, pretty y]) xs) + pretty (VectorExpr xs) = listoid "[|" "|]" (map pretty xs) + + pretty (LambdaExpr xs y) = pretty "\\" <> hsep (map pretty xs) <+> pretty "->" <> nest 2 (softline <> pretty y) + pretty (PatternFunctionExpr xs y) = pretty "\\" <> hsep (map pretty xs) <+> pretty "=>" <> softline <> pretty y + + pretty (UnaryOpExpr op x) = pretty op <> pretty x + pretty (BinaryOpExpr op x@(BinaryOpExpr op' _ _) y) + | priority op > priority op' = parens (pretty x) <+> pretty (repr op) <+> pretty' y + | otherwise = pretty x <+> pretty (repr op) <+> pretty' y + pretty (BinaryOpExpr op x y) = pretty x <+> pretty (repr op) <+> pretty' y + + pretty (ApplyExpr x (TupleExpr ys)) = nest 2 (pretty x <+> fillSep (map pretty ys)) + +instance Pretty Arg where + pretty (ScalarArg x) = pretty x + pretty (InvertedScalarArg x) = pretty "*$" <> pretty x + pretty (TensorArg x) = pretty '%' <> pretty x + +instance Pretty Var where + -- TODO: indices + pretty (Var xs is) = concatWith (surround dot) (map pretty xs) + +instance Pretty InnerExpr where + pretty (ElementExpr x) = pretty x + pretty (SubCollectionExpr _) = error "Not supported" + +instance Pretty EgisonPattern where + pretty x = undefined + +pretty' :: EgisonExpr -> Doc ann +pretty' x@(UnaryOpExpr _ _) = parens $ pretty x +pretty' x = pretty x + +listoid :: String -> String -> [Doc ann] -> Doc ann +listoid lp rp elems = encloseSep (pretty lp) (pretty rp) (comma <> space) elems diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -25,7 +25,7 @@ import Data.Foldable (toList) import Data.IORef import Data.Ratio -import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA ((=~~)) import System.IO import System.Process (readProcess) @@ -140,8 +140,8 @@ constants :: [(String, EgisonValue)] constants = [ - ("f.pi", Float 3.141592653589793 0) - ,("f.e" , Float 2.718281828459045 0) + ("f.pi", Float 3.141592653589793) + ,("f.e" , Float 2.718281828459045) ] -- @@ -157,10 +157,10 @@ , ("b.-'", minus) , ("b.*'", multiply) , ("b./'", divide) - , ("f.+", floatPlus) - , ("f.-", floatMinus) - , ("f.*", floatMult) - , ("f./", floatDivide) + , ("f.+", floatBinaryOp (+)) + , ("f.-", floatBinaryOp (-)) + , ("f.*", floatBinaryOp (*)) + , ("f./", floatBinaryOp (/)) , ("numerator", numerator') , ("denominator", denominator') , ("from-math-expr", fromScalarData) @@ -168,7 +168,7 @@ , ("to-math-expr'", toScalarData) , ("modulo", integerBinaryOp mod) - , ("quotient", integerBinaryOp quot) + , ("quotient", integerBinaryOp quot) , ("remainder", integerBinaryOp rem) , ("b.abs", rationalUnaryOp abs) , ("b.neg", rationalUnaryOp negate) @@ -183,8 +183,6 @@ , ("floor", floatToIntegerOp floor) , ("ceiling", floatToIntegerOp ceiling) , ("truncate", truncate') - , ("real-part", realPart) - , ("imaginary-part", imaginaryPart) , ("b.sqrt", floatUnaryOp sqrt) , ("b.sqrt'", floatUnaryOp sqrt) @@ -263,10 +261,10 @@ , ("b.-'", minus) , ("b.*'", multiply) , ("b./'", divide) - , ("f.+", floatPlus) - , ("f.-", floatMinus) - , ("f.*", floatMult) - , ("f./", floatDivide) + , ("f.+", floatBinaryOp (+)) + , ("f.-", floatBinaryOp (-)) + , ("f.*", floatBinaryOp (*)) + , ("f./", floatBinaryOp (/)) , ("numerator", numerator') , ("denominator", denominator') , ("fromMathExpr", fromScalarData) @@ -289,8 +287,6 @@ , ("floor", floatToIntegerOp floor) , ("ceiling", floatToIntegerOp ceiling) , ("truncate", truncate') - , ("realPart", realPart) - , ("imaginaryPart", imaginaryPart) , ("b.sqrt", floatUnaryOp sqrt) , ("b.sqrt'", floatUnaryOp sqrt) @@ -392,12 +388,12 @@ floatUnaryOp :: (Double -> Double) -> PrimitiveFunc floatUnaryOp op = oneArg $ \val -> case val of - (Float f 0) -> return $ Float (op f) 0 + (Float f) -> return $ Float (op f) _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc floatBinaryOp op = twoArgs $ \val val' -> case (val, val') of - (Float f 0, Float f' 0) -> return $ Float (op f f') 0 + (Float f, Float f') -> return $ Float (op f f') _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc @@ -406,27 +402,7 @@ f' <- fromEgison val' return $ Bool $ pred f f' -floatPlus :: PrimitiveFunc -floatPlus = twoArgs $ \val val' -> case (val, val') of - (Float x y, Float x' y') -> return $ Float (x + x') (y + y') - _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack -floatMinus :: PrimitiveFunc -floatMinus = twoArgs $ \val val' -> case (val, val') of - (Float x y, Float x' y') -> return $ Float (x - x') (y - y') - _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - -floatMult :: PrimitiveFunc -floatMult = twoArgs $ \val val' -> case (val, val') of - (Float x y, Float x' y') -> return $ Float (x * x' - y * y') (x * y' + x' * y) - _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - -floatDivide :: PrimitiveFunc -floatDivide = twoArgs $ \val val' -> case (val, val') of - (Float x y, Float x' y') -> return $ Float ((x * x' + y * y') / (x' * x' + y' * y')) ((y * x' - x * y') / (x' * x' + y' * y')) - _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - - -- -- Arith -- @@ -487,10 +463,10 @@ r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (<) r r' - scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<) f f' - scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryPred' (Float f) (Float f') = return $ Bool (f < f') + scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryPred' (Float _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack + scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack lte :: PrimitiveFunc lte = twoArgs' $ \val val' -> scalarBinaryPred' val val' @@ -499,10 +475,10 @@ r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (<=) r r' - scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<=) f f' - scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryPred' (Float f) (Float f') = return $ Bool (f <= f') + scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryPred' (Float _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack + scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack gt :: PrimitiveFunc gt = twoArgs' $ \val val' -> scalarBinaryPred' val val' @@ -511,10 +487,10 @@ r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (>) r r' - scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>) f f' + scalarBinaryPred' (Float f) (Float f') = return $ Bool $ (f > f') scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryPred' (Float _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack + scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack gte :: PrimitiveFunc gte = twoArgs' $ \val val' -> scalarBinaryPred' val val' @@ -523,31 +499,19 @@ r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (>=) r r' - scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>=) f f' - scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryPred' (Float f) (Float f') = return $ Bool (f >= f') + scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryPred' (Float _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack + scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val where numberUnaryOp' (ScalarData (Div (Plus []) _)) = return $ toEgison (0 :: Integer) numberUnaryOp' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return $ toEgison (quot x y) - numberUnaryOp' (Float x _) = return $ toEgison (truncate x :: Integer) + numberUnaryOp' (Float x) = return $ toEgison (truncate x :: Integer) numberUnaryOp' val = throwError =<< TypeMismatch "rational or float" (Value val) <$> getFuncNameStack -realPart :: PrimitiveFunc -realPart = oneArg realPart' - where - realPart' (Float x y) = return $ Float x 0 - realPart' val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - -imaginaryPart :: PrimitiveFunc -imaginaryPart = oneArg imaginaryPart' - where - imaginaryPart' (Float _ y) = return $ Float y 0 - imaginaryPart' val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack - -- -- Tensor -- @@ -574,8 +538,8 @@ -- Transform -- numberToFloat' :: EgisonValue -> EgisonValue -numberToFloat' (ScalarData (Div (Plus []) _)) = Float 0 0 -numberToFloat' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = Float (fromRational (x % y)) 0 +numberToFloat' (ScalarData (Div (Plus []) _)) = Float 0 +numberToFloat' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = Float $ fromRational (x % y) integerToFloat :: PrimitiveFunc integerToFloat = rationalToFloat @@ -645,22 +609,20 @@ regexString :: PrimitiveFunc regexString = twoArgs $ \pat src -> case (pat, src) of - (String patStr, String srcStr) -> do - let (a, b, c) = (T.unpack srcStr =~ T.unpack patStr) :: (String, String, String) - if b == "" - then return . Collection . Sq.fromList $ [] - else return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]] + (String patStr, String srcStr) -> + case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of + Nothing -> return . Collection . Sq.fromList $ [] + Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]] (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack regexStringCaptureGroup :: PrimitiveFunc regexStringCaptureGroup = twoArgs $ \pat src -> case (pat, src) of - (String patStr, String srcStr) -> do - let ret = (T.unpack srcStr =~ T.unpack patStr) :: [[String]] - case ret of - [] -> return . Collection . Sq.fromList $ [] - ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr - return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]] + (String patStr, String srcStr) -> + case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe [[String]]) of + Nothing -> return . Collection . Sq.fromList $ [] + Just ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr + return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]] (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -26,7 +26,7 @@ , InnerExpr (..) , BindingExpr (..) , MatchClause (..) - , MatcherInfo (..) + , PatternDef (..) , LoopRange (..) , PrimitivePatPattern (..) , PrimitiveDataPattern (..) @@ -195,7 +195,6 @@ import qualified Data.Text as T import Data.Ratio -import Numeric (showFFloat) import System.IO import System.IO.Unsafe (unsafePerformIO) @@ -221,7 +220,7 @@ | StringExpr Text | BoolExpr Bool | IntegerExpr Integer - | FloatExpr Double Double + | FloatExpr Double | VarExpr Var | FreshVarExpr | IndexedExpr Bool EgisonExpr [Index EgisonExpr] -- True -> delete old index and append new one @@ -258,14 +257,12 @@ | MatchLambdaExpr EgisonExpr [MatchClause] | MatchAllLambdaExpr EgisonExpr [MatchClause] - | MatcherExpr MatcherInfo + | MatcherExpr [PatternDef] | AlgebraicDataMatcherExpr [(String, [EgisonExpr])] | QuoteExpr EgisonExpr | QuoteSymbolExpr EgisonExpr - - | WedgeExpr EgisonExpr -- Desugared to WedgeApplyExpr - | WedgeApplyExpr EgisonExpr EgisonExpr -- Appears after desugar + | WedgeApplyExpr EgisonExpr EgisonExpr | DoExpr [BindingExpr] EgisonExpr | IoExpr EgisonExpr @@ -323,7 +320,7 @@ type BindingExpr = ([Var], EgisonExpr) type MatchClause = (EgisonPattern, EgisonExpr) -type MatcherInfo = [(PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])] +type PatternDef = (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) -- TODO(momohatt): AndPat and OrPat take only 2 arguments in new syntax data EgisonPattern = @@ -433,7 +430,7 @@ | Bool Bool | ScalarData ScalarData | TensorData (Tensor EgisonValue) - | Float Double Double + | Float Double | InductiveData String [EgisonValue] | Tuple [EgisonValue] | Collection (Seq EgisonValue) @@ -441,7 +438,7 @@ | IntHash (HashMap Integer EgisonValue) | CharHash (HashMap Char EgisonValue) | StrHash (HashMap Text EgisonValue) - | UserMatcher Env MatcherInfo + | UserMatcher Env [PatternDef] | Func (Maybe Var) Env [String] EgisonExpr | PartialFunc Env Integer EgisonExpr | CFunc (Maybe Var) Env String EgisonExpr @@ -1217,16 +1214,16 @@ removePairs :: (Int, Int) -> [a] -> [a] removePairs (m, n) xs = - let (hs, ms, ts) = removePairs' (m, n) xs in - hs ++ ms ++ ts + let (hs, ms, ts) = removePairs' (m, n) xs + in hs ++ ms ++ ts removePairs' :: (Int, Int) -> [a] -> ([a],[a],[a]) -removePairs' (m, n) xs = -- (0,1) [i i] - let (hms, tts) = splitAt n xs in -- [i] [i] - let ts = tail tts in -- [] - let (hs, tms) = splitAt m hms in -- [] [i] - let ms = tail tms in -- [] - (hs, ms, ts) -- [] [] [] +removePairs' (m, n) xs = -- (0,1) [i i] + let (hms, tts) = splitAt n xs -- [i] [i] + ts = tail tts -- [] + (hs, tms) = splitAt m hms -- [] [i] + ms = tail tms -- [] + in (hs, ms, ts) -- [] [] [] -- -- -- @@ -1241,7 +1238,7 @@ show (BoolExpr True) = "#t" show (BoolExpr False) = "#f" show (IntegerExpr n) = show n - show (FloatExpr x y) = showComplexFloat x y + show (FloatExpr x) = show x show (VarExpr name) = show name show (PartialVarExpr n) = "%" ++ show n show (FunctionExpr args) = "(function [" ++ unwords (map show args) ++ "])" @@ -1277,7 +1274,7 @@ f j [] = "" f j xs = "[| " ++ unwords (map show (take j xs)) ++ " |] " ++ f j (drop j xs) show (TensorData (Tensor ns xs js)) = "(tensor {" ++ unwords (map show ns) ++ "} {" ++ unwords (map show (V.toList xs)) ++ "} )" ++ concatMap show js - show (Float x y) = showComplexFloat x y + show (Float x) = show x show (InductiveData name []) = "<" ++ name ++ ">" show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">" show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]" @@ -1342,18 +1339,6 @@ show (FunctionData Nothing argnames args js) = "(functionData [" ++ unwords (map show argnames) ++ "])" ++ concatMap show js show (FunctionData (Just name) argnames args js) = show name ++ concatMap show js -showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String -showComplex x 0 = show x -showComplex 0 y = show y ++ "i" -showComplex x y = show x ++ (if y > 0 then "+" else "") ++ show y ++ "i" - -showComplexFloat :: Double -> Double -> String -showComplexFloat x 0.0 = showFFloat Nothing x "" -showComplexFloat 0.0 y = showFFloat Nothing y "i" -showComplexFloat x y = showFFloat Nothing x "" ++ if y > 0 - then "+" ++ showFFloat Nothing y "i" - else showFFloat Nothing y "i" - showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map show vals) showTSV (Collection vals) = intercalate "\t" (map show (toList vals)) @@ -1365,7 +1350,7 @@ (Bool b) == (Bool b') = b == b' (ScalarData x) == (ScalarData y) = x == y (TensorData (Tensor js xs _)) == (TensorData (Tensor js' xs' _)) = (js == js') && (xs == xs') - (Float x y) == (Float x' y') = (x == x') && (y == y') + (Float x) == (Float x') = x == x' (InductiveData name vals) == (InductiveData name' vals') = (name == name') && (vals == vals') (Tuple vals) == (Tuple vals') = vals == vals' (Collection vals) == (Collection vals') = vals == vals' @@ -1457,9 +1442,9 @@ fromEgison val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack instance EgisonData Double where - toEgison f = Float f 0 - fromEgison (Float f 0) = return f - fromEgison val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack + toEgison f = Float f + fromEgison (Float f) = return f + fromEgison val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack instance EgisonData Handle where toEgison = Port @@ -1574,8 +1559,8 @@ fromWHNF whnf = throwError =<< TypeMismatch "integer" whnf <$> getFuncNameStack instance EgisonWHNF Double where - fromWHNF (Value (Float f 0)) = return f - fromWHNF whnf = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack + fromWHNF (Value (Float f)) = return f + fromWHNF whnf = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack instance EgisonWHNF Handle where fromWHNF (Value (Port h)) = return h @@ -1948,7 +1933,7 @@ isScalar _ = False isScalar' :: PrimitiveFunc -isScalar' (Value val) = return $ Value $ Bool $ isScalar val +isScalar' (Value (ScalarData _)) = return $ Value $ Bool $ True isScalar' _ = return $ Value $ Bool False isTensor :: EgisonValue -> Bool @@ -1956,7 +1941,8 @@ isTensor _ = False isTensor' :: PrimitiveFunc -isTensor' (Value val) = return $ Value $ Bool $ isTensor val +isTensor' (Value (TensorData _)) = return $ Value $ Bool $ True +isTensor' (Intermediate (ITensor _)) = return $ Value $ Bool $ True isTensor' _ = return $ Value $ Bool False isTensorWithIndex :: EgisonValue -> Bool @@ -1968,12 +1954,12 @@ isTensorWithIndex' _ = return $ Value $ Bool False isFloat' :: PrimitiveFunc -isFloat' (Value (Float _ 0)) = return $ Value $ Bool True -isFloat' _ = return $ Value $ Bool False +isFloat' (Value (Float _)) = return $ Value $ Bool True +isFloat' _ = return $ Value $ Bool False isComplex' :: PrimitiveFunc -isComplex' (Value (Float _ _)) = return $ Value $ Bool True -isComplex' _ = return $ Value $ Bool False +isComplex' (Value (Float _)) = return $ Value $ Bool True +isComplex' _ = return $ Value $ Bool False isChar' :: PrimitiveFunc isChar' (Value (Char _)) = return $ Value $ Bool True @@ -2041,9 +2027,8 @@ optTestOnly :: Bool, optPrompt :: String, optMathExpr :: Maybe String, - optSExpr :: Bool, - optUseNonS2 :: Bool + optSExpr :: Bool } defaultOption :: EgisonOpts -defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True False +defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True diff --git a/hs-src/Language/Egison/Util.hs b/hs-src/Language/Egison/Util.hs --- a/hs-src/Language/Egison/Util.hs +++ b/hs-src/Language/Egison/Util.hs @@ -19,7 +19,6 @@ import Language.Egison.Parser as Parser import Language.Egison.ParserNonS as ParserNonS -import Language.Egison.ParserNonS2 as ParserNonS2 import Language.Egison.Types -- |Get Egison expression from the prompt. We can handle multiline input. @@ -41,7 +40,7 @@ history <- getHistory putHistory $ addHistoryUnlessConsecutiveDupe line history let input = prev ++ line - let parsedExpr = (if optUseNonS2 opts then ParserNonS2.parseTopExpr else if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input + let parsedExpr = (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" diff --git a/hs-src/Tool/translator.hs b/hs-src/Tool/translator.hs new file mode 100644 --- /dev/null +++ b/hs-src/Tool/translator.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Main where + +import Control.Arrow ((***)) +import Data.Char (toUpper) +import Data.List (find) +import Data.List.Split (splitOn) +import Data.Maybe (fromJust) +import Data.Text.Prettyprint.Doc.Render.Text (putDoc) +import System.Environment (getArgs) + +import Language.Egison.Types +import Language.Egison.Parser +import Language.Egison.Pretty + +class SyntaxElement a where + toNonS :: a -> a + +instance SyntaxElement EgisonTopExpr where + toNonS (Define x y) = Define (toNonS x) (toNonS y) + toNonS (Redefine x y) = error "Not supported" + toNonS (Test x) = Test (toNonS x) + toNonS (Execute x) = Execute (toNonS x) + toNonS x = x + +instance SyntaxElement EgisonExpr where + toNonS (IntegerExpr x) + | x < 0 = UnaryOpExpr "-" (IntegerExpr (-x)) + | otherwise = IntegerExpr x + toNonS (VarExpr x) = VarExpr (toNonS x) + + toNonS (IndexedExpr b x ys) = IndexedExpr b (toNonS x) (map toNonS ys) + toNonS (SubrefsExpr b x y) = SubrefsExpr b (toNonS x) (toNonS y) + toNonS (SuprefsExpr b x y) = SuprefsExpr b (toNonS x) (toNonS y) + toNonS (UserrefsExpr b x y) = UserrefsExpr b (toNonS x) (toNonS y) + toNonS (PowerExpr x y) = BinaryOpExpr powerOp (toNonS x) (toNonS y) + where powerOp = fromJust $ find (\op -> repr op == "^") reservedBinops + toNonS (InductiveDataExpr x ys) = InductiveDataExpr x (map toNonS ys) + toNonS (TupleExpr xs) = TupleExpr (map toNonS xs) + toNonS (CollectionExpr xs) = CollectionExpr (map toNonS xs) + toNonS (ArrayExpr xs) = ArrayExpr (map toNonS xs) + toNonS (HashExpr xs) = HashExpr (map (toNonS *** toNonS) xs) + toNonS (VectorExpr xs) = VectorExpr (map toNonS xs) + + toNonS (LambdaExpr xs y) = LambdaExpr xs (toNonS y) + toNonS (MemoizedLambdaExpr xs y) = MemoizedLambdaExpr xs (toNonS y) + toNonS (CambdaExpr _ _) = error "Not supported" + toNonS (ProcedureExpr xs y) = ProcedureExpr xs (toNonS y) + toNonS (MacroExpr xs y) = MacroExpr xs (toNonS y) + -- PatternFunctionExpr + + toNonS (IfExpr x y z) = IfExpr (toNonS x) (toNonS y) (toNonS z) + toNonS (LetRecExpr xs y) = LetRecExpr (map toNonS xs) (toNonS y) + toNonS (LetExpr xs y) = LetExpr (map toNonS xs) (toNonS y) + toNonS (LetStarExpr xs y) = LetStarExpr (map toNonS xs) (toNonS y) + toNonS (WithSymbolsExpr xs y) = WithSymbolsExpr xs (toNonS y) + + toNonS (MatchExpr x y zs) = MatchExpr (toNonS x) (toNonS y) (map toNonS zs) + toNonS (MatchDFSExpr x y zs) = MatchDFSExpr (toNonS x) (toNonS y) (map toNonS zs) + toNonS (MatchAllExpr x y zs) = MatchAllExpr (toNonS x) (toNonS y) (map toNonS zs) + toNonS (MatchAllDFSExpr x y zs) = MatchAllDFSExpr (toNonS x) (toNonS y) (map toNonS zs) + toNonS (MatchLambdaExpr x ys) = MatchLambdaExpr (toNonS x) (map toNonS ys) + toNonS (MatchAllLambdaExpr x ys) = MatchAllLambdaExpr (toNonS x) (map toNonS ys) + + toNonS (MatcherExpr xs) = MatcherExpr (map toNonS xs) + + toNonS (QuoteExpr x) = QuoteExpr (toNonS x) + toNonS (QuoteSymbolExpr x) = QuoteSymbolExpr (toNonS x) + toNonS (WedgeApplyExpr x y) = WedgeApplyExpr (toNonS x) (toNonS y) + + toNonS (DoExpr xs y) = DoExpr (map toNonS xs) (toNonS y) + toNonS (IoExpr x) = IoExpr (toNonS x) + + toNonS (ApplyExpr x@(VarExpr (Var [f] [])) (TupleExpr [y, z])) = + case find (\op -> repr op == f) reservedBinops of + Just op -> BinaryOpExpr op (toNonS y) (toNonS z) + Nothing -> ApplyExpr x (TupleExpr [toNonS y, toNonS z]) + + toNonS x = x + +instance SyntaxElement a => SyntaxElement (Index a) where + toNonS (Subscript x) = Subscript (toNonS x) + toNonS (Superscript x) = Superscript (toNonS x) + toNonS (SupSubscript x) = SupSubscript (toNonS x) + toNonS (MultiSubscript x y) = MultiSubscript (toNonS x) (toNonS y) + toNonS (MultiSuperscript x y) = MultiSuperscript (toNonS x) (toNonS y) + toNonS (Userscript x) = Userscript (toNonS x) + toNonS (DotSubscript x) = DotSubscript (toNonS x) + toNonS (DotSupscript x) = DotSupscript (toNonS x) + toNonS x = x -- DFScript + +instance SyntaxElement InnerExpr where + toNonS (ElementExpr x) = ElementExpr (toNonS x) + toNonS (SubCollectionExpr _) = error "Not supported" + +instance SyntaxElement BindingExpr where + toNonS (vars, x) = (map toNonS vars, toNonS x) + +instance SyntaxElement MatchClause where + toNonS (x, y) = (x, toNonS y) + +instance SyntaxElement PatternDef where + toNonS (x, y, zs) = (x, toNonS y, map (\(z, w) -> (z, toNonS w)) zs) + +instance SyntaxElement Var where + toNonS (Var xs ys) = Var (map toCamelCase xs) ys + where + toCamelCase :: String -> String + toCamelCase x = + let heads:tails = splitOn "-" x + in concat $ heads : map (\ (x:xs) -> toUpper x : xs) tails + +main :: IO () +main = do + args <- getArgs + input <- readFile $ head args + -- 'ast' is not desugared + let ast = parseTopExprs input + case ast of + Left _ -> return () + Right ast -> do + putDoc $ prettyTopExprs $ map toNonS ast + putStrLn "" diff --git a/nons-test/test/lib/core/base.egi b/nons-test/test/lib/core/base.egi new file mode 100644 --- /dev/null +++ b/nons-test/test/lib/core/base.egi @@ -0,0 +1,55 @@ +-- +-- Matchers +-- + +assert "bool's value pattern" + (match (True, False) as (bool, bool) with + | #(True, False) -> True + | _ -> False) + +assert "char's value pattern" + (match 'a' as char with + | #'a' -> True + | _ -> False) + +assert "integer's value pattern" + (match 10 as integer with + | #10 -> True + | _ -> False) + +assert "float's value pattern" + (match 0.1 as float with + | #0.1 -> True + | _ -> False) + +-- +-- Utility +-- +assertEqual "id" (id 1) 1 + +assertEqual "fst" (fst (1, 2)) 1 + +assertEqual "snd" (snd (1, 2)) 2 + +assertEqual "compose - case 1" ((compose (fst, snd)) ((1, 2), 3)) 2 + +assertEqual "compose - case 2" ((compose (fst, snd, fst)) ((1, (2, 3)), 4)) 2 + +-- assertEqual("eq?/m", +-- eq?/m(integer, 1, 1), +-- True) + +-- +-- Booleans +-- +assertEqual "and" + [True && True, True && False, False && True, False && False] + [True, False, False, False] + +assertEqual "or" + [True || True, True || False, False || True, False || False] + [True, True, True, False] + +assertEqual "not" + [not True, not False] + [False, True] diff --git a/nons-test/test/lib/core/order.egi b/nons-test/test/lib/core/order.egi new file mode 100644 --- /dev/null +++ b/nons-test/test/lib/core/order.egi @@ -0,0 +1,35 @@ +assertEqual "compare - case 1" + (compare 10 10) + Equal + +assertEqual "compare - case 2" + (compare 11 10) + Greater + +assertEqual "compare - case 3" + (compare 10 11) + Less + +assertEqual "min" + (min [20, 5]) + 5 + +-- assertEqual "min/fn" +-- (min/fn compare [10, 20, 5, 20, 30]) +-- 5 + +assertEqual "max" + (max [5, 30]) + 30 + +-- assertEqual "max/fn" +-- (max/fn compare [10, 20, 5, 20, 30]) +-- 30 + +assertEqual "sort" + (sort [10, 20, 5, 20, 30]) + [5, 10, 20, 20, 30] + +-- assertEqual "sort/fn" +-- (sort/fn compare [10, 20, 5, 20, 30]) +-- [5, 10, 20, 20, 30] diff --git a/nons-test/test/primitive.egi b/nons-test/test/primitive.egi new file mode 100644 --- /dev/null +++ b/nons-test/test/primitive.egi @@ -0,0 +1,175 @@ +assertEqual "numerator" (numerator (13 / 21)) 13 + +assertEqual "denominator" (denominator (13 / 21)) 21 + +assertEqual "modulo" (modulo (-21) 13) 5 + +assertEqual "quotient" (quotient (-21) 13) (-1) + +assertEqual "remainder" (remainder (-21) 13) (-8) + +assertEqual "neg" (neg (-89)) 89 + +assertEqual "abs" (abs 0) 0 +assertEqual "abs" (abs 15) 15 +assertEqual "abs" (abs (-89)) 89 + +assertEqual "lt?" (0.1 < 1.0) True +assertEqual "lt?" (1.0 < 0.1) False +assertEqual "lt?" (1.0 < 1.0) False + +assertEqual "lte?" (0.1 <= 1.0) True +assertEqual "lte?" (1.0 <= 0.1) False +assertEqual "lte?" (1.0 <= 1.0) True + +assertEqual "gt?" (0.1 > 1.0) False +assertEqual "gt?" (1.0 > 0.1) True +assertEqual "gt?" (1.0 > 1.0) False + +assertEqual "gte?" (0.1 >= 1.0) False +assertEqual "gte?" (1.0 >= 0.1) True +assertEqual "gte?" (1.0 >= 1.0) True + +assertEqual "round" (round 3.1) 3 +assertEqual "round" (round 3.7) 4 +assertEqual "round" (round (-2.2)) (-2) +assertEqual "round" (round (-2.7)) (-3) + +assertEqual "floor" (floor 3.1) 3 +assertEqual "floor" (floor 3.7) 3 +assertEqual "floor" (floor (-2.2)) (-3) +assertEqual "floor" (floor (-2.7)) (-3) + +assertEqual "ceiling" (ceiling 3.1) 4 +assertEqual "ceiling" (ceiling 3.7) 4 +assertEqual "ceiling" (ceiling (-2.2)) (-2) +assertEqual "ceiling" (ceiling (-2.7)) (-2) + +assertEqual "truncate" (truncate 3.1) 3 +assertEqual "truncate" (truncate 3.7) 3 +assertEqual "truncate" (truncate (-2.2)) (-2) +assertEqual "truncate" (truncate (-2.7)) (-2) + +-- assertEqual "sqrt" (sqrt 4) 2 +assertEqual "sqrt" (sqrt 4.0) 2.0 +-- assertEqual "sqrt" (sqrt (-1)) i + +-- assertEqual "exp" +-- [exp 1, exp 1.0, exp (-1.0)] +-- [e, 2.718281828459045, 0.36787944117144233] + +-- assertEqual "log" +-- [log e, log 10.0] +-- [1, 2.302585092994046] + +-- TODO: trigonometric functions +-- * sin +-- * cos +-- * tan +-- * asin +-- * acos +-- * sinh +-- * cosh +-- * tanh +-- * asinh +-- * acosh +-- * atanh + +-- tensorSize +-- tensorToList +-- dfOrder + +assertEqual "itof" (itof 4) 4.0 +assertEqual "itof" (itof (-1)) (-1.0) + +assertEqual "rtof" (rtof (3 / 2)) 1.5 +assertEqual "rtof" (rtof 1) 1.0 + +assertEqual "ctoi" (ctoi '1') 49 + +assertEqual "itoc" (itoc 49) '1' + +assertEqual "pack" (pack []) "" +assertEqual "pack" (pack ['E', 'g', 'i', 's', 'o', 'n']) "Egison" + +assertEqual "unpack" (unpack "Egison") ['E', 'g', 'i', 's', 'o', 'n'] +assertEqual "unpack" (unpack "") [] + +assertEqual "unconsString" (unconsString "Egison") ('E', "gison") + +assertEqual "lengthString" (lengthString "") 0 +assertEqual "lengthString" (lengthString "Egison") 6 + +assertEqual "appendString" (appendString "" "") "" +assertEqual "appendString" (appendString "" "Egison") "Egison" +assertEqual "appendString" (appendString "Egison" "") "Egison" +assertEqual "appendString" (appendString "Egi" "son") "Egison" + +assertEqual "splitString" (splitString "," "") [""] +assertEqual "splitString" (splitString "," "2,3,5,7,11,13") ["2", "3", "5", "7", "11", "13"] + +assertEqual "regex" (regex "cde" "abcdefg") [("ab", "cde", "fg")] +assertEqual "regex" (regex "[0-9]+" "abc123defg") [("abc", "123", "defg")] +assertEqual "regex" (regex "a*" "") [("", "", "")] + +assertEqual "regexCg" (regexCg "([0-9]+),([0-9]+)" "abc,123,45,defg") [("abc,", ["123", "45"], ",defg")] + +-- addPrime +-- addSubscript +-- addSuperscript +-- readProcess + +assertEqual "read" (read "3") 3 +assertEqual "read" (read "3.14") 3.14 +assertEqual "read" (read "{1 2}") [1, 2] +assertEqual "read" (read "\"Hello world!\"") "Hello world!" + +-- TODO: read-tsv + +assertEqual "show" (show 3) "3" +assertEqual "show" (show 3.14159) "3.14159" +assertEqual "show" (show [1, 2]) "{1 2}" +assertEqual "show" (show "Hello world!") "\"Hello world!\"" + +-- TODO: show-tsv + +assertEqual "empty?" (empty? []) True +assertEqual "empty?" (empty? [1]) False + +assertEqual "uncons" (uncons [1, 2, 3]) (1, [2, 3]) +assertEqual "unsnoc" (unsnoc [1, 2, 3]) ([1, 2], 3) + +assertEqual "bool?" (bool? False) True + +assertEqual "integer?" (integer? 1) True + +assertEqual "rational?" (rational? 1) True +assertEqual "rational?" (rational? (1 / 2)) True +assertEqual "rational?" (rational? 3.1) False + +assertEqual "scalar?" (scalar? 1) True +assertEqual "scalar?" (scalar? (| 1, 2 |)) False + +assertEqual "float?" (float? 1.0) True +assertEqual "float?" (float? 1) False + +assertEqual "char?" (char? 'c') True + +assertEqual "string?" (string? "hoge") True + +assertEqual "collection?" (collection? []) True +assertEqual "collection?" (collection? [1]) True + +assertEqual "array?" (array? (| |)) True +assertEqual "array?" (array? (| 1, 2, 3 |)) True + +assertEqual "hash?" (hash? {| |}) True +assertEqual "hash?" (hash? {| [1, 2] |}) True + +-- TODO: Add a test case where tensor? returns True +assertEqual "tensor?" (tensor? 1) False +assertEqual "tensor?" (tensor? (| 1 |)) False +assertEqual "tensor?" (tensor? [| 1 |]) True +assertEqual "tensor?" (tensor? (generateTensor (+) [1, 2])) True + +-- TODO: tensorWithIndex? diff --git a/nons-test/test/syntax.egi b/nons-test/test/syntax.egi new file mode 100644 --- /dev/null +++ b/nons-test/test/syntax.egi @@ -0,0 +1,467 @@ +-- +-- Syntax test +-- + +-- +-- Primitive Data +-- + +assertEqual "char literal" + ['a', '\n', '\''] + ['a', '\n', '\''] + +assertEqual "string literal" "" "" +assertEqual "string literal" "abc\n" "abc\n" + +assertEqual "bool literal" + [True, False] + [True, False] + +assertEqual "integer literal" + [1, 0, -100, 1 - 100] + [1, 0, -100, -99] + +assertEqual "rational number" + [10 / 3, 10 / 20, -1 / 2] + [10 / 3 , 1 / 2, -1 / 2] + +assertEqual "float literal" [1.0, 0.0, -100.012001, 1.0 + 2] [1.0, 0.0, -100.012001, 3.0] + +assertEqual "inductive data literal" A A + +assertEqual "tuple literal" (1, 2, 3) (1, 2, 3) + +assertEqual "singleton tuple literal" (1) 1 + +assertEqual "collection literal" [1, 2, 3, 4, 5, 6] [1, 2, 3, 4, 5, 6] + +assertEqual "collection between" [1..5] [1, 2, 3, 4, 5] +assertEqual "collection from" (take 5 [1..]) [1, 2, 3, 4, 5] + +-- +-- Basic Sytax +-- + +assertEqual "if" + (if True then True else False) + True + +assertEqual "if" + (if False then True else False) + False + +assertEqual "let binding" + (let t = (1, 2) + (x, y) = t + in x + y) + 3 + +assertEqual "let binding" + (let x = 1 + y = x + 1 + in y) + 2 + +assertEqual "mutual recursion" + (let even? n = if n == 0 then True else odd? (n - 1) + odd? n = if n == 0 then False else even? (n - 1) + in even? 10) + True + +assertEqual "lambda and application" + ((\x -> x + 1) 10) + 11 + +assertEqual "application with binops" + ((\x y -> x + y) 1 2 + 3) + 6 + +assertEqual "append op" ([1] ++ [2]) [1, 2] +assertEqual "append op" ((++) [1] [2]) [1, 2] + +assertEqual "point free expr" ((+) 10 1) 11 +assertEqual "point free expr" ((+ 1) 10) 11 +assertEqual "point free expr" (foldl (*) 1 [1..5]) 120 +assertEqual "point free expr" ((10 -) 1) 9 +assertEqual "point free expr" ((10 - ) 1) 9 +assertEqual "not point free expr" (- 2) (1 - 3) + +-- findFactor = memoizedLambda +-- n -> match takeWhile (<= floor (sqrt (itof n))) primes as list integer with +-- | _ ++ (?(\m -> divisor? n m) && $x) : _ -> x +-- | _ -> n +-- assertEqual "memoized lambda" +-- (map findFactor [1..10]) +-- [1, 2, 3, 2, 5, 2, 7, 2, 3, 2] + +twinPrimes = + matchAll primes as list integer with + | _ ++ $p : #(p + 2) : _ -> (p, p + 2) + +assertEqual "twin primes" + (take 10 twinPrimes) + [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73), (101, 103), (107, 109)] + +someFunction x y z = + x + y * z + +assertEqual "function definition" + (someFunction 1 2 3) + 7 + +gcd m n = + if (m >= n) then + if (n == 0) then m + else gcd n (m % n) + else gcd n m + +assertEqual "recursive function definition" + (gcd 143 22) + 11 + +-- +-- Pattern-Matching +-- + +assertEqual "match" + (match 1 as integer with + | #0 -> 0 + | $x -> 10 + x) + 11 + +assertEqual "match-all" + (matchAll [1, 2, 3] as multiset integer with + | $x : _ -> x) + [1, 2, 3] + +assertEqual "match-all-multi" + (matchAll [1, 2, 3] as multiset integer with + | $x : #(x + 1) : _ -> [x, x + 1] + | $x : #(x + 2) : _ -> [x, x + 2]) + [[1, 2], [2, 3], [1, 3]] + +assertEqual "match-lambda" + ((\match as list integer with + | [] -> 0 + | $x : _ -> x) [1, 2, 3]) + 1 + +assertEqual "match-all-lambda" + ((\matchAll as list something with + | _ ++ $x : _ -> x) [1, 2, 3]) + [1, 2, 3] + +assertEqual "match-all-lambda-multi" + ((\matchAll as multiset something with + | $x : #(x + 1) : _ -> [x, x + 1] + | $x : #(x + 2) : _ -> [x, x + 2]) [1, 2, 3]) + [[1, 2], [2, 3], [1, 3]] + +assert "nested pattern match" + (match [1, 2, 3] as list integer with + | #2 : $x -> match x as multiset integer with + | _ -> False + | #1 : $x -> match x as multiset integer with + | #1 : _ -> False + | #2 : _ -> True) + +assertEqual "pattern variable" + (match 1 as something with $x -> x) + 1 + +assert "value pattern" (match 1 as integer with #1 -> True) + +assert "inductive pattern" + (match [1, 2, 3] as list integer with + | snoc #3 _ -> True) + +assert "and pattern" + (match [1, 2, 3] as list integer with + | #1 : _ && snoc #3 _ -> True) + +assert "and pattern" + (match [1, 2, 3] as list integer with + | #1 : _ && #3 : _ -> False + | _ -> True) + +assert "or pattern" + (match [1, 2, 3] as list integer with + | snoc #1 _ || snoc #3 _ -> True) + +assert "or pattern" + (match [1, 2, 3] as list integer with + | #2 : _ || #1 : _ -> True) + +assert "not pattern" + (match 1 as integer with + | ! #1 -> False + | ! #2 -> True) + +assertEqual "not pattern" + (matchAll [1, 2, 2, 3, 3, 3] as multiset integer with + | $n : !(#n : _) -> n) + [1] + +assert "predicate pattern" + (match [1, 2, 3] as list integer with + | ?(== 1) : _ -> True) + +assert "predicate pattern" + (match [1, 2, 3] as list integer with + | ?(== 2) : _ -> False + | _ -> True) + +assertEqual "indexed pattern variable" + (match 23 as mod 10 with + | $a_1 -> a) + {| [1, 23] |} + +assert "loop pattern" + (match [3, 2, 1] as list integer with + | loop $i (1, [3], _) + | snoc #i ... + | [] -> True) + +assertEqual "loop pattern" + (match [1..10] as list integer with + | loop $i (1, $n) + | #i : ... + | [] -> n) + 10 + +assert "loop pattern" + (match [3, 2, 1] as list integer with + | loop $i (1, [3], _) + | snoc #i ... + | [] -> True) + +assertEqual "double loop pattern" + (match [[1, 2, 3], [4, 5, 6], [7, 8, 9]] as (list (list integer)) with + | loop $i (1, [3], _) + | ((loop $j (1, [3], _) + | $n_i_j : ... + | []) : ...) + | [] -> n) + {| [1, {| [1, 1], [2, 2], [3, 3] |}], + [2, {| [1, 4], [2, 5], [3, 6] |}], + [3, {| [1, 7], [2, 8], [3, 9] |}] |} + +assertEqual "let pattern" + (match [1, 2, 3] as list integer with + | let a = 42 in _ -> a) + 42 + +assertEqual "let pattern" + (match [1, 2, 3] as list integer with + | $a : (let x = a in $xs) -> [x, xs]) + [1, [2, 3]] + +assertEqual "let pattern" + (match [1, 2, 3] as list integer with + | $a && (let n = length a in _) -> [a, n]) + [[1, 2, 3], 3] + +assertEqual "tuple pattern" + (matchAll (1, (2, 3)) as (integer, (integer, integer)) with + | ($m, ($n, $w)) -> [m, n, w]) + [[1, 2, 3]] + +assertEqual "tuple pattern" + (matchAll [(1, 1), (2, 2)] as multiset (integer, integer) with + | ($x, #x) : _ -> x) + [1, 2] + +-- assertEqual "pattern function call" +-- (let twin = \pat1 pat2 => (~pat1 && $x) : #x : ~pat2 in +-- match [1, 1, 1, 2, 3] as list integer with +-- | twin $n $ns -> [n, ns]) +-- [1, [1, 2, 3]] + +-- assertEqual "recursive pattern function call" +-- (let repeat = \pat => [] || (~pat && $x) : (repeat x) in +-- match [1, 1, 1, 1] as list integer with +-- | repeat $n -> n) +-- 1 + +-- assertEqual "loop pattern in pattern function" +-- let comb n = \p => +-- loop $i (1, n, _) _ ++ ~p_i : ... | _ +-- in +-- matchAll [1, 2, 3, 4, 5] as (list integer) with +-- | (comb 2) $n -> n +-- [{|[1, 1], [2, 2]|}, {|[1, 1], [2, 3]|}, {|[1, 2], [2, 3]|}, {|[1, 1], [2, 4]|}, {|[1, 2], [2, 4]|}, {|[1, 3], [2, 4]|}, {|[1, 1], [2, 5]|}, {|[1, 2], [2, 5]|}, {|[1, 3], [2, 5]|}, {|[1, 4], [2, 5]|}] + +assertEqual "pairs of 2, natural numbers" + (take 10 (matchAll nats as set integer with + | $m : $n : _ -> [m, n])) + [[1, 1], [1, 2], [2, 1], [1, 3], [2, 2], [3, 1], [1, 4], [2, 3], [3, 2], [4, 1]] + +assertEqual "pairs of 2, different natural numbers" + (take 10 (matchAll nats as list integer with + | _ ++ $m : _ ++ $n : _ -> [m, n])) + [[1, 2], [1, 3], [2, 3], [1, 4], [2, 4], [3, 4], [1, 5], [2, 5], [3, 5], [4, 5]] + +tree a = algebraicDataMatcher + | leaf + | node (tree a) a (tree a) + +treeInsert n t = + match t as tree integer with + | leaf -> Node Leaf n Leaf + | node $t1 $m $t2 -> match (compare n m) as ordering with + | less -> Node (treeInsert n t1) m t2 + | equal -> Node t1 n t2 + | greater -> Node t1 m (treeInsert n t2) + +treeMember? n t = + match t as tree integer with + | leaf -> False + | node $t1 $m $t2 -> match (compare n m) as ordering with + | less -> treeMember? n t1 + | equal -> True + | greater -> treeMember? n t2 + +assertEqual "tree set using algebraic-data-matcher" + (let t = foldr treeInsert Leaf [4, 1, 2, 4, 3] + in [treeMember? 1 t, treeMember? 0 t]) + [True, False] + +assert "sequential pattern" + (match [2,3,1,4,5] as list integer with + { @ : @ : $x : _, + (#(x + 1), @), + #(x + 2)} -> True) + +-- +-- Tensor +-- + +assertEqual "generate-tensor" + (generateTensor (*) [3, 5]) + [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |], [| 3, 6, 9, 12, 15 |] |] + +assertEqual "tensor" + (tensor [2, 5] [1, 2, 3, 4, 5, 2, 4, 6, 8, 10]) + [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |] |] + +assertEqual "tensor wedge expr" + (! b.min [| 1, 2, 3 |] [| 1, 2, 3 |]) + [| [| 1, 1, 1 |], [| 1, 2, 2 |], [| 1, 2, 3 |] |] + +assertEqual "tensor wedge expr of binary operator" + ([| 1, 2, 3 |] !+ [| 1, 2, 3 |]) + [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |] + +assertEqual "tensor multiplication" + ([| 1, 2, 3 |]_i * [| 1, 2, 3 |]_i) + [| 1, 4, 9 |]_i + +-- +-- Hash +-- + +assertEqual "hash-literal" + {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |} + {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |} + +assertEqual "empty hash-literal" + {| |} + {| |} + +assertEqual "hash access" + {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |}_3 + 13 + +-- +-- Partial Application +-- +-- assertEqual "partial application '$'" +-- ($ + $)(1, 2) +-- 3 +-- +-- assertEqual "partial application '$' with index" +-- ($2-$1)(1, 2) +-- 1 +-- +-- assertEqual "partial application '#'" +-- 2#(10 * %1 + %2)(1, 2) +-- 12 +-- +-- assertEqual "recursive partial application '#'" +-- take(10, 1#[%1, @(%0(%1 * 2))](2)) +-- [2, 4, 8, 16, 32, 64, 128, 256, 512, 1024] + +f *x *y = x + y + +assertEqual "double inverted index" + (f [|1, 2, 3|]_i [|10, 20, 30|]_j) + [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]~i~j + +g x *y = x + y + +assertEqual "single inverted index" + (g [|1, 2, 3|]_i [|10, 20, 30|]_j) + [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]_i~j + +-- +-- matcherExpr, macroExpr +-- + +list a = matcher + | [] as () with + | [] -> [()] + | _ -> [] + | $ : $ as (a, list a) with + | $x : $xs -> [(x, xs)] + | _ -> [] + | snoc $ $ as (a, list a) with + | snoc $xs $x -> [(x, xs)] + | _ -> [] + | join _ $ as (list a) with + | $tgt -> matchAll tgt as list a with + | loop $i (1, _) | _ : ... | $rs -> rs + | join $ $ as (list a, list a) with + | $tgt -> matchAll tgt as list a with + | loop $i (1, $n) $xa_i : ... | $rs -> + (foldr (\%i %r -> xa_i : r) [] [1..n], rs) + | nioj $ $ as (list a, list a) with + | $tgt -> matchAll tgt as list a with + | loop $i (1, $n) snoc $xa_i ... | $rs -> + (foldr (\%i %r -> r ++ [xa_i]) [] [1..n], rs) + | #$val as () with + | $tgt -> if val == tgt then [()] else [] + | $ as something with + | $tgt -> [tgt] + +multiset a = matcher + | [] as () with + | $tgt -> match tgt as (mutiset a) with + | [] -> [()] + | _ -> [] + | $ : $ as (a, multiset a) with + | $tgt -> matchAll tgt as list a with + | $hs ++ $x : $ts -> (x, hs ++ ts) + | #$val as () with + | $tgt -> match (val, tgt) as (list a, multiset a) with + | ([], []) -> [()] + | ($x : $xs, #x : #xs) -> [()] + | (_, _) -> [] + | $ as something with + | $tgt -> [tgt] + +assertEqual "matcher definition" + (matchAll [1, 2, 3] as multiset integer with + | $x : _ -> x) + [1, 2, 3] + +nishiwakiIf = + macro b e1 e2 -> + car (matchAll b as (matcher + | $ as something with + | True -> [e1] + | False -> [e2]) with + | $x -> x) + +assertEqual "case 1" (nishiwakiIf True 1 2) 1 +assertEqual "case 2" (nishiwakiIf False 1 2) 2 +assertEqual "case 3" (nishiwakiIf (1 == 1) 1 2) 1 diff --git a/sample/unify.egi b/sample/unify.egi --- a/sample/unify.egi +++ b/sample/unify.egi @@ -52,8 +52,6 @@ (Just {})] [[ (& $t !(occur ,x))] (Just {[x t]})] - [[> >] - (Just {})] [[ ] (unify-list xs ys)] [_ Nothing]})) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -16,7 +16,7 @@ import Language.Egison import Language.Egison.Core import qualified Language.Egison.Parser as Parser -import qualified Language.Egison.ParserNonS2 as ParserNonS2 +import qualified Language.Egison.ParserNonS as ParserNonS import Language.Egison.Primitives import Language.Egison.Types @@ -74,9 +74,9 @@ runUnitTestCaseNonS :: FilePath -> Test runUnitTestCaseNonS file = TestLabel file . TestCase $ do - env <- initialEnv (defaultOption { optUseNonS2 = True }) + env <- initialEnv (defaultOption { optSExpr = False }) assertEgisonM $ do - exprs <- ParserNonS2.loadFile file + exprs <- ParserNonS.loadFile file let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs env' <- recursiveBind env bindings forM_ tests $ evalExprDeep env' diff --git a/test/answer/sample/mahjong.egi b/test/answer/sample/mahjong.egi new file mode 100644 --- /dev/null +++ b/test/answer/sample/mahjong.egi @@ -0,0 +1,2 @@ +#t +#f diff --git a/test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi b/test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi new file mode 100644 --- /dev/null +++ b/test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi @@ -0,0 +1,23 @@ +[| [| (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |] [| (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |] |]_i_j +[| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_# +[| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~# +(tensor {2 2 2} {0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 (* r^2 (sin θ) (cos θ)) (* r^2 (sin θ) (cos θ)) 0} )_#_#_# +[| [| 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_# +[| [| 0 (* r^2 (sin θ) (cos θ)) |] [| (* r^2 (sin θ) (cos θ)) 0 |] |]_#_# +(tensor {2 2 2} {0 0 0 (* -1 (sin θ) (cos θ)) 0 (/ (cos θ) (sin θ)) (/ (cos θ) (sin θ)) 0} )~#_#_# +[| [| 0 0 |] [| 0 (* -1 (sin θ) (cos θ)) |] |]_#_# +[| [| 0 (/ (cos θ) (sin θ)) |] [| (/ (cos θ) (sin θ)) 0 |] |]_#_# +(tensor {2 2 2} {0 0 0 0 0 0 0 0} )_#_#_# +(tensor {2 2 2 2} {0 0 0 0 0 (sin θ)^2 (* -1 (sin θ)^2) 0 0 -1 1 0 0 0 0 0} )~#_#_#_# +[| [| 0 0 |] [| 0 0 |] |]~#_# +[| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_# +[| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_# +[| [| 0 0 |] [| 0 0 |] |]~#_# +(tensor {2 2 2 2} {0 0 0 0 0 (* r^2 (sin θ)^2) (* -1 r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) (* r^2 (sin θ)^2) 0 0 0 0 0} )_#_#_#_# +[| [| 0 0 |] [| 0 0 |] |]_#_# +[| [| 0 (* r^2 (sin θ)^2) |] [| (* -1 r^2 (sin θ)^2) 0 |] |]_#_# +[| [| 0 (* -1 r^2 (sin θ)^2) |] [| (* r^2 (sin θ)^2) 0 |] |]_#_# +[| [| 0 0 |] [| 0 0 |] |]_#_# +[| [| 1 0 |] [| 0 (sin θ)^2 |] |]_#_# +(/ 2 r^2) +(tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_# diff --git a/test/answer/sample/math/number/17th-root-of-unity.egi b/test/answer/sample/math/number/17th-root-of-unity.egi new file mode 100644 --- /dev/null +++ b/test/answer/sample/math/number/17th-root-of-unity.egi @@ -0,0 +1,2 @@ +(/ (+ -1 (sqrt 17) (* (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* -2 (sqrt 2) (sqrt (+ 17 (sqrt 17)))))))) 8) +(/ (+ -1 (sqrt 17) (* (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* -2 (sqrt 2) (sqrt (+ 17 (sqrt 17)))))))) 8) diff --git a/test/answer/sample/poker-hands-with-joker.egi b/test/answer/sample/poker-hands-with-joker.egi new file mode 100644 --- /dev/null +++ b/test/answer/sample/poker-hands-with-joker.egi @@ -0,0 +1,4 @@ + + + + diff --git a/test/answer/sample/poker-hands.egi b/test/answer/sample/poker-hands.egi new file mode 100644 --- /dev/null +++ b/test/answer/sample/poker-hands.egi @@ -0,0 +1,4 @@ +"Straight flush" +"Full house" +"Straight" +"Nothing" diff --git a/test/answer/sample/primes.egi b/test/answer/sample/primes.egi new file mode 100644 --- /dev/null +++ b/test/answer/sample/primes.egi @@ -0,0 +1,2 @@ +{[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]} +{[5 7 11] [7 11 13] [11 13 17] [13 17 19] [17 19 23] [37 41 43] [41 43 47] [67 71 73] [97 101 103] [101 103 107]} diff --git a/test/lib/core/base.egi b/test/lib/core/base.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/base.egi @@ -0,0 +1,68 @@ +;; +;; Matchers +;; +(assert "bool's value pattern" + (match [#t #f] [bool bool] + {[[,#t ,#f] #t] + [_ #f]})) + +(assert "char's value pattern" + (match c#a char + {[,c#a #t] + [_ #f]})) + +(assert "integer's value pattern" + (match 10 integer + {[,10 #t] + [_ #f]})) + +(assert "float's value pattern" + (match 0.1 float + {[,0.1 #t] + [_ #f]})) + +;; +;; Utility +;; +(assert-equal "id" + (id 1) + 1) + +(assert-equal "fst" + (fst [1 2]) + 1) + +(assert-equal "snd" + (snd [1 2]) + 2) + +(assert-equal "compose - case 1" + ((compose fst snd) [[1 2] 3]) + 2) + +(assert-equal "compose - case 2" + ((compose fst snd fst) [[1 [2 3]] 4]) + 2) + +; (assert-equal "ref" +; (ref (| 1 2 3 |) 2) +; 2) + +(assert-equal "eq?/m" + (eq?/m integer 1 1) + #t) + +;; +;; Booleans +;; +(assert-equal "and" + [(and #t #t) (and #t #f) (and #f #t) (and #f #f)] + [#t #f #f #f]) + +(assert-equal "or" + [(or #t #t) (or #t #f) (or #f #t) (or #f #f)] + [#t #t #t #f]) + +(assert-equal "not" + [(not #t) (not #f)] + [#f #t]) diff --git a/test/lib/core/collection.egi b/test/lib/core/collection.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/collection.egi @@ -0,0 +1,417 @@ +;;;;; +;;;;; Collection Test +;;;;; + +;;; +;;; List Pattern-Matching +;;; +(assert "list's value pattern" + (match {1 2 3} (list integer) + {[,{@{@{1}} @{2 @{3}}} #t] + [_ #f]})) + +(assert "list's nil - case 1" + (match {} (list integer) + {[ #t] + [_ #f]})) + +(assert "list's nil - case 2" + (match {1} (list integer) + {[ #f] + [_ #t]})) + +(assert-equal "list's cons" + (match {1 2 3} (list integer) + {[ [n ns]]}) + [1 {2 3}]) + +(assert-equal "list's cons with value pattern" + (match {1 2 3} (list integer) + {[ ns]}) + {2 3}) + +(assert-equal "list's snoc" + (match {1 2 3} (list integer) + {[ [n ns]]}) + [3 {1 2}]) + +(assert-equal "list's snoc with value pattern" + (match {1 2 3} (list integer) + {[ ns]}) + {1 2}) + +(assert-equal "list's join" + (match-all {1 2 3} (list integer) + [ [xs ys]]) + {[{} {1 2 3}] + [{1} {2 3}] + [{1 2} {3}] + [{1 2 3} {}]}) + +(assert-equal "list's join with value pattern" + (match {1 2 3} (list integer) + {[ ns]}) + {2 3}) + +(assert-equal "list's nioj" + (match-all {1 2 3} (list integer) + [ [xs ys]]) + {[{} {1 2 3}] + [{3} {1 2}] + [{2 3} {1}] + [{1 2 3} {}]}) + +(assert-equal "list's nioj with value pattern" + (match {1 2 3} (list integer) + {[ ns]}) + {1 2}) + +;;; +;;; Multiset Pattern-Matching +;;; +(assert "multiset's nil - case 1" + (match {} (multiset integer) + {[ #t] + [_ #f]})) + +(assert "multiset's nil - case 2" + (match {1} (multiset integer) + {[ #f] + [_ #t]})) + +(assert "multiset's value pattern" + (match {1 1 1 2 3} (multiset integer) + {[,{@{@{1}} @{2 @{1 3}} 1} #t] + [_ #f]})) + +(assert-equal "multiset's cons" + (match-all {1 2 3} (multiset integer) + [ [n ns]]) + {[1 {2 3}] [2 {1 3}] [3 {1 2}]}) + +(assert-equal "multiset's cons with value pattern" + (match {1 2 3} (multiset integer) + {[ ns]}) + {1 3}) + +(assert-equal "multiset's join" + (match-all {1 2 3} (multiset integer) + [ [xs ys]]) + {[{} {1 2 3}] [{1} {2 3}] [{2} {1 3}] [{3} {1 2}] [{1 2} {3}] [{1 3} {2}] [{2 3} {1}] [{1 2 3} {}]}) + +(assert-equal "multiset's join with value pattern - case 1" + (match {1 2 3} (multiset integer) + {[ ns]}) + {2 3}) + +(assert-equal "multiset's join with value pattern - case 2" + (match-all {1 2 3} (multiset integer) + [ ys]) + {{2}}) + +(assert-equal "multiset's join with value pattern - case 3" + (match-all {1 2 3} (multiset integer) + [ ys]) + {}) + +;;; +;;; Set Pattern-Matching +;;;; +(assert "set's nil - case 1" + (match {} (set integer) + {[ #t] + [_ #f]})) + +(assert "set's nil - case 2" + (match {1} (set integer) + {[ #f] + [_ #t]})) + +(assert-equal "set's cons" + (match-all {1 2 3} (set integer) + [ [n ns]]) + {[1 {1 2 3}] [2 {1 2 3}] [3 {1 2 3}]}) + +(assert-equal "set's cons with value pattern" + (match {1 2 3} (set integer) + {[ ns]}) + {1 2 3}) + +(assert-equal "set's join" + (match-all {1 2 3} (set integer) + [ [xs ys]]) + {[{} {1 2 3}] [{1} {1 2 3}] [{2} {1 2 3}] [{3} {1 2 3}] [{1 2} {1 2 3}] [{1 3} {1 2 3}] [{2 3} {1 2 3}] [{1 2 3} {1 2 3}]}) + +(assert-equal "set's join with value pattern 1" + (match-all {1 2 3} (set integer) + [ ys]) + {{1 2 3}}) + +(assert-equal "set's join with value pattern 2" + (match-all {1 2 3} (set integer) + [ ys]) + {}) + +;; +;; Simple accessors +;; +(assert-equal "nth" + (nth 1 {1 2 3}) + 1) + +(assert-equal "take" + (take 2 {1 2 3}) + {1 2}) + +(assert-equal "drop" + (drop 2 {1 2 3}) + {3}) + +(assert-equal "take-and-drop" + (take-and-drop 2 {1 2 3}) + [{1 2} {3}]) + +(assert-equal "take-while" + (take-while (lt? $ 10) primes) + {2 3 5 7}) + +;; +;; cons, car, cdr +;; + +(assert-equal "cons" + (cons 1 {2 3}) + {1 2 3}) + +(assert-equal "car" + (car {1 2 3}) + 1) + +(assert-equal "cdr" + (cdr {1 2 3}) + {2 3}) + +(assert-equal "rac" + (rac {1 2 3}) + 3) + +(assert-equal "rdc" + (rdc {1 2 3}) + {1 2}) + +;; +;; List Functions +;; +(assert-equal "length" + (length {1 2 3}) + 3) + +(assert-equal "map" + (map (* $ 2) {1 2 3}) + {2 4 6}) + +(assert-equal "map2" + (map2 (* $ $) {1 2 3} {10 20 30}) + {10 40 90} + ) + +(assert-equal "filter" + (let {[$odd? (lambda [$n] (eq? (modulo n 2) 1))]} + (filter odd? {1 2 3})) + {1 3}) + +(assert-equal "zip" + (zip {1 2 3} {10 20 30}) + {[1 10] [2 20] [3 30]}) + +(assert-equal "lookup" + (lookup 2 {[1 10] [2 20] [3 30]}) + 20) + +(assert-equal "foldr" + (foldr (lambda [$n $ns] {n @ns}) {} {1 2 3}) + {1 2 3}) + +(assert-equal "foldl" + (foldl (lambda [$ns $n] {n @ns}) {} {1 2 3}) + {3 2 1}) + +(assert-equal "scanl" + (scanl (lambda [$r $n] (* r n)) 2 {2 2 2}) + {2 4 8 16}) + +(assert-equal "append" + (append {1 2} {3 4 5}) + {1 2 3 4 5}) + +(assert-equal "concat" + (concat {{1 2} {3 4 5}}) + {1 2 3 4 5}) + +(assert-equal "reverse" + (reverse {1 2 3}) + {3 2 1}) + +(assert-equal "intersperse" + (intersperse {0} {{1 2} {3 3} {4} {}}) + {{1 2} {0} {3 3} {0} {4} {0} {}}) + +(assert-equal "intercalate" + (intercalate {0} {{1 2} {3 3} {4} {}}) + {1 2 0 3 3 0 4 0}) + +(assert-equal "split" + (split {0} {1 2 0 3 3 0 4 0}) + {{1 2} {3 3} {4} {}}) + +(assert-equal "split/m" + (split/m integer {0} {1 2 0 3 3 0 4 0}) + {{1 2} {3 3} {4} {}}) + +(assert-equal "find-cycle" + (find-cycle {1 3 4 5 2 7 5 2 7 5 2 7}) + [{1 3 4} {5 2 7}]) + +(assert-equal "repeat" + (take 5 (repeat {1 2 3})) + {1 2 3 1 2}) + +(assert-equal "repeat1" + (take 5 (repeat1 2)) + {2 2 2 2 2}) + +;; +;; Others +;; +(assert-equal "all - case 1" + (all (eq? $ 1) {1 1 1}) + #t) + +(assert-equal "all - case 2" + (all (eq? $ 1) {1 1 2}) + #f) + +(assert-equal "any - case 1" + (any (eq? $ 1) {0 1 0}) + #t) + +(assert-equal "any - case 2" + (any (eq? $ 1) {0 0 0}) + #f) + +(assert-equal "from" + (take 3 (from 2)) + {2 3 4}) + +(assert-equal "between" + (between 2 5) + {2 3 4 5}) + +;; +;; Multiset Functions +;; +(assert-equal "add - case 1" + (add 1 {2 3}) + {2 3 1}) + +(assert-equal "add - case 2" + (add 1 {1 2 3}) + {1 2 3}) + +(assert-equal "add/m - case 1" + (add/m integer 1 {2 3}) + {2 3 1}) + +(assert-equal "add/m - case 2" + (add/m integer 1 {1 2 3}) + {1 2 3}) + +(assert-equal "delete-first" + (delete-first 2 {1 2 3 2}) + {1 3 2}) + +(assert-equal "delete-first/m" + (delete-first/m integer 2 {1 2 3 2}) + {1 3 2}) + +(assert-equal "delete" + (delete 2 {1 2 3 1 2 3}) + {1 3 1 3}) + +(assert-equal "delete/m" + (delete/m integer 2 {1 2 3 1 2 3}) + {1 3 1 3}) + +(assert-equal "difference" + (difference {1 2 3} {1 3}) + {2}) + +(assert-equal "difference/m" + (difference/m integer {1 2 3} {1 3}) + {2}) + +(assert-equal "union" + (union {1 2 3} {1 3 4}) + {1 2 3 4}) + +(assert-equal "union/m" + (union/m integer {1 2 3} {1 3 4}) + {1 2 3 4}) + +(assert-equal "intersect" + (intersect {1 2 3} {1 3 4}) + {1 3}) + +(assert-equal "intersect/m" + (intersect/m integer {1 2 3} {1 3 4}) + {1 3}) + +;; +;; Simple predicate +;; + +(assert-equal "member? - case 1" + (member? 1 {1 3 1 4}) + #t) + +(assert-equal "member? - case 2" + (member? 2 {1 3 1 4}) + #f) + +(assert-equal "member?/m - case 1" + (member?/m integer 1 {1 3 1 4}) + #t) + +(assert-equal "member?/m - case 2" + (member?/m integer 2 {1 3 1 4}) + #f) + +;; +;; Counting +;; +(assert-equal "count" + (count 1 {1 3 1 4}) + 2) + +(assert-equal "count/m" + (count/m integer 1 {1 3 1 4}) + 2) + +(assert-equal "frequency" + (frequency {1 3 1 4}) + {[1 2] [3 1] [4 1]}) + +(assert-equal "frequency/m" + (frequency/m integer {1 3 1 4}) + {[1 2] [3 1] [4 1]}) + +;; +;; Set Functions +;; +(assert-equal "unique" + (unique {1 2 3 2 1 4}) + {1 2 3 4}) + +(assert-equal "unique/m" + (unique/m integer {1 2 3 2 1 4}) + {1 2 3 4}) diff --git a/test/lib/core/number.egi b/test/lib/core/number.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/number.egi @@ -0,0 +1,143 @@ +;; +;; Matcher +;; +(assert-equal "nat's o - case 1" + (match 0 nat + {[ #t] + [_ #f]}) + #t) + +(assert-equal "nat's o - case 2" + (match 1 nat + {[ #t] + [_ #f]}) + #f) + +(assert-equal "nat's s - case 1" + (match 10 nat + {[ n]}) + 9) + +(assert-equal "nat's s - case 2" + (match 0 nat + {[> #t] + [_ #f]}) + #f) + +;; +;; Sequences +;; +(assert-equal "nats" + (take 10 nats) + {1 2 3 4 5 6 7 8 9 10}) + +(assert-equal "nats0" + (take 10 nats0) + {0 1 2 3 4 5 6 7 8 9}) + +(assert-equal "odds" + (take 10 odds) + {1 3 5 7 9 11 13 15 17 19}) + +(assert-equal "evens" + (take 10 evens) + {2 4 6 8 10 12 14 16 18 20}) + +(assert-equal "primes" + (take 10 primes) + {2 3 5 7 11 13 17 19 23 29}) + +;; +;; Natural numbers +;; +(assert-equal "divisor?" + (divisor? 10 5) + #t) + +(assert-equal "find-factor" + (find-factor 100) + 2) + +(assert-equal "p-f" + (p-f 100) + {2 2 5 5}) + +(assert-equal "odd? - case 1" + (odd? 3) + #t) + +(assert-equal "odd? - case 2" + (odd? 4) + #f) + +(assert-equal "even? - case 1" + (even? 4) + #t) + +(assert-equal "even? - case 2" + (even? 5) + #f) + +(assert-equal "prime? - case 1" + (prime? 17) + #t) + +(assert-equal "prime? - case 2" + (prime? 18) + #f) + +(assert-equal "perm" + (perm 5 2) + 20) + +(assert-equal "comb" + (comb 5 2) + 10) + +(assert-equal "n-adic - case 1" + (n-adic 10 123) + {1 2 3}) + +(assert-equal "n-adic - case 2" + (n-adic 2 10) + {1 0 1 0}) + +;; +;; Dicimal fractions +;; +(assert-equal "rtod" + (2#[%1 (take 10 %2)] (rtod (/ 6 35))) + [0 {1 7 1 4 2 8 5 7 1 4}]) + +(assert-equal "rtod'" + (rtod' (/ 6 35)) + [0 {1} {7 1 4 2 8 5}]) + +(assert-equal "show-decimal" + (show-decimal 10 (/ 6 35)) + "0.1714285714") + +(assert-equal "show-decimal'" + (show-decimal' (/ 6 35)) + "0.1 714285 ...") + +(assert-equal "regular-continued-fraction sqrt of 2" + (rtof (regular-continued-fraction 1 {2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2})) + 1.4142135623730951) + +(assert-equal "regular-continued-fraction pi" + (rtof (regular-continued-fraction 3 {7 15 1 292 1 1 1 2 1 3 1 14 2 1 1 2 2 2 2 1 84 2 1 1 15 3 13})) + 3.141592653589793) + +(assert-equal "continued-fraction pi" + (rtof (continued-fraction 3 {7 15 1 292 1 1 1 2 1 3 1 14 2 1 1 2 2 2 2 1 84 2 1 1 15 3 13} + {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1})) + 3.141592653589793) + +(assert-equal "regular-continued-fraction-of-sqrt case 1" + (2#[%1 (take 10 %2)] (regular-continued-fraction-of-sqrt 2)) + [1 {2 2 2 2 2 2 2 2 2 2}]) + +(assert-equal "regular-continued-fraction-of-sqrt case 2" + (rtof (regular-continued-fraction (2#[%1 (take 100 %2)] (regular-continued-fraction-of-sqrt 2)))) + 1.4142135623730951) diff --git a/test/lib/core/order.egi b/test/lib/core/order.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/order.egi @@ -0,0 +1,35 @@ +(assert-equal "compare - case 1" + (compare 10 10) + ) + +(assert-equal "compare - case 2" + (compare 11 10) + ) + +(assert-equal "compare - case 3" + (compare 10 11) + ) + +(assert-equal "min" + (min {20 5}) + 5) + +(assert-equal "min/fn" + (min/fn compare {10 20 5 20 30}) + 5) + +(assert-equal "max" + (max {5 30}) + 30) + +(assert-equal "max/fn" + (max/fn compare {10 20 5 20 30}) + 30) + +(assert-equal "sort" + (sort {10 20 5 20 30}) + {5 10 20 20 30}) + +(assert-equal "sort/fn" + (sort/fn compare {10 20 5 20 30}) + {5 10 20 20 30}) diff --git a/test/lib/core/string.egi b/test/lib/core/string.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/string.egi @@ -0,0 +1,99 @@ +(assert "string's value pattern" + (match "abc" string + {[,"abc" #t] + [_ #f]})) + +(assert "string's nil - case 1" + (match "" string + {[ #t] + [_ #f]})) + +(assert "string's nil - case 2" + (match "abc" string + {[ #f] + [_ #t]})) + +(assert-equal "string's cons" + (match-all "abc" string + [ [x xs]]) + {[c#a "bc"]}) + +(assert-equal "string's join" + (match-all "abc" string + [ [xs ys]]) + {["" "abc"] ["a" "bc"] + ["ab" "c"] ["abc" ""]}) + +;;; +;;; String as collection +;;; +(assert-equal "S.empty? - case 1" + (S.empty? "") + #t) + +(assert-equal "S.empty? - case 2" + (S.empty? "Egison") + #f) + +(assert-equal "S.car" + (S.car "Egison") + c#E) + +(assert-equal "S.cdr" + (S.cdr "Egison") + "gison") + +(assert-equal "S.rac" + (S.rac "Egison") + c#n) + +(assert-equal "S.map" + (S.map id "Egison") + "Egison") + +(assert-equal "S.length" + (S.length "Egison") + 6) + +(assert-equal "S.split" + (S.split "," "Lisp,Haskell,Egison") + {"Lisp" "Haskell" "Egison"}) + +(assert-equal "S.append" + (S.append "Egi" "son") + "Egison") + +(assert-equal "S.concat" + (S.concat {"Egi" "son"}) + "Egison") + +(assert-equal "S.intercalate" + (S.intercalate "," {"Lisp" "Haskell" "Egison"}) + "Lisp,Haskell,Egison") + +;; +;; Characters +;; +(assert-equal "C.between" + (C.between c#a c#c) + {c#a c#b c#c}) + +(assert-equal "C.between?" + (C.between? c#a c#c c#b) + #t) + +(assert-equal "alphabet?" + (alphabet? c#a) + #t) + +(assert-equal "alphabets?" + (alphabets? "Egison") + #t) + +(assert-equal "upper-case" + (upper-case c#e) + c#E) + +(assert-equal "lower-case" + (lower-case c#E) + c#e) diff --git a/test/lib/math/algebra.egi b/test/lib/math/algebra.egi new file mode 100644 --- /dev/null +++ b/test/lib/math/algebra.egi @@ -0,0 +1,15 @@ +(assert-equal "q-f' - case 1" + (q-f' 1 2 1) + [-1 -1]) + +(assert-equal "q-f' - case 2" + (q-f' 1 1 -1) + [(/ (+ -1 (sqrt 5)) 2) (/ (+ -1 (* -1 (sqrt 5))) 2)]) + +(assert-equal "q-f' - case 3" + (q-f' 1 (* -1 (/ (+ -1 (sqrt 5)) 2)) 1) + [(/ (+ -1 (sqrt 5) (sqrt (+ -10 (* -2 (sqrt 5))))) 4) (/ (+ -1 (sqrt 5) (* -1 (sqrt (+ -10 (* -2 (sqrt 5)))))) 4)]) + +(assert-equal "fifth root of unity" + (** (/ (+ -1 (sqrt 5) (sqrt (+ -10 (* -2 (sqrt 5))))) 4) 5) + 1) diff --git a/test/lib/math/analysis.egi b/test/lib/math/analysis.egi new file mode 100644 --- /dev/null +++ b/test/lib/math/analysis.egi @@ -0,0 +1,41 @@ +(assert-equal "d/d - case 1" + (d/d (** x 2) x) + (* 2 x)) + +(assert-equal "d/d - case 2" + (d/d (** a (** x 2)) x) + (* 2 (** a x^2) (log a) x)) + +(assert-equal "d/d - case 3" + (d/d (* (cos x) (sin x)) x) + (+ (* -1 (sin x)^2) (cos x)^2)) + +(assert-equal "d/d - case 4" + (d/d (sigmoid z) z) + (/ (exp (* -1 z)) (+ 1 (* 2 (exp (* -1 z))) (exp (* -1 z))^2))) + +(assert-equal "d/d - case 5" + (d/d (d/d (log x) x) x) + (/ -1 x^2)) + +(assert-equal "tailor-expansion - case 1" + (take 4 (taylor-expansion (** e (* i x)) x 0)) + {1 (* i x) (/ (* -1 x^2) 2) (/ (* -1 i x^3) 6)}) + +(assert-equal "tailor-expansion - case 2" + (take 4 (taylor-expansion (* i (sin x)) x 0)) + {0 (* i x) 0 (/ (* -1 i x^3) 6)}) + +;(assert-equal "multivariate-tailor-expansion - case 1" +; (take 3 (multivariate-taylor-expansion (f x y) [| x y |] [| 0 0 |])) +; {(f 0 0) (+ (* x (f|1 0 0)) (* y (f|2 0 0))) (/ (+ (* x^2 (f|1|1 0 0)) (* 2 x y (f|1|2 0 0)) (* y^2 (f|2|2 0 0))) 2)}) + +(assert-equal "multivariate-tailor-expansion - case 2" + (take 3 (multivariate-taylor-expansion (** e (+ x y)) [| x y |] [| 0 0 |])) + {1 (+ x y) (/ (+ x^2 (* 2 x y) y^2) 2)}) + +(assert-equal "function expr" + (let {[$f (function [x y])]} + (d/d f y)) + (let {[$f (function [x y])]} + (user-refs f {y}))) diff --git a/test/lib/math/arithmetic.egi b/test/lib/math/arithmetic.egi new file mode 100644 --- /dev/null +++ b/test/lib/math/arithmetic.egi @@ -0,0 +1,31 @@ +(assert-equal "sum" + (sum (take 5 nats)) + 15) + +(assert-equal "product" + (product (take 5 nats)) + 120) + +(assert-equal "power" + (power 2 5) + 32) + +(assert-equal "** - case 1" + (power x 3) + x^3) + +(assert-equal "** - case 2" + (power (sqrt 2) 4) + 4) + +(assert-equal "gcd" + (gcd 15 40) + 5) + +(assert-equal "sqrt - case 1" + (sqrt (/ (* 50 x^2) y)) + (/ (* 5 x (sqrt (* 2 y))) y)) + +(assert-equal "sqrt - case 2" + (* (sqrt (* 3 x)) (sqrt (* 2 y))) + (* (sqrt 6) (sqrt x) (sqrt y))) diff --git a/test/lib/math/tensor.egi b/test/lib/math/tensor.egi new file mode 100644 --- /dev/null +++ b/test/lib/math/tensor.egi @@ -0,0 +1,85 @@ +(assert-equal "Tensor product - case 1" + (. [| [| 1 1 |] [| 0 1 |] |]~i~j [| [| 1 1 |] [| 0 1 |] |]_j_k) + [| [| 1 2 |] [| 0 1 |] |]) + +(assert-equal "Tensor product - case 2" + (. [| [| 1 1 |] [| 0 1 |] |]~i~j [| [| 1 1 |] [| 0 1 |] |]_j~k [| [| 1 1 |] [| 0 1 |] |]_k_l) + [| [| 1 3 |] [| 0 1 |] |]~i_l) + +(assert-equal "Vector *" + (V.* [| 1 1 0 |] [| 10 5 10 |]) + 15) + +(assert-equal "Matrix * - case 1" + (M.* [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |]) + [| [| 1 2 |] [| 0 1 |] |]) + +(assert-equal "Matrix * - case 2" + (M.* [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |]) + [| [| 1 3 |] [| 0 1 |] |]) + +(assert-equal "Tensor '+' - case 1" + (+ 1 [|1 2 3|]) + [|2 3 4|]) + +(assert-equal "Tensor '+' - case 2" + (+ [|1 2 3|] 1) + [|2 3 4|]) + +(assert-equal "Tensor '+' - case 3" + (+ [|[|11 12|] + [|21 22|] + [|31 32|]|]_i_j + [|100 200 300|]_i) + [| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j) + +(assert-equal "Tensor '+' - case 4" + (+ [|100 200 300|]_i + [|[|11 12|] + [|21 22|] + [|31 32|]|]_i_j) + [| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j) + +(assert-equal "Tensor '+' - case 5" + (+ [|[|1 2 3|] + [|10 20 30|]|]_i_j + [|100 200 300|]_j) + [| [| 101 202 303 |] [| 110 220 330 |] |]_i_j) + +(assert-equal "Tensor '+' - case 6" + (+ [|100 200 300|]_j + [|[|1 2 3|] + [|10 20 30|]|]_i_j) + [| [| 101 110 |] [| 202 220 |] [| 303 330 |] |]_j_i) + +;(assert-equal "Tensor ∂/∂ - case 1" +; (∂/∂ [|(f x) (g x)|] x) +; [|(f|1 x) (g|1 x)|]) + +;(assert-equal "Tensor ∂/∂ - case 2" +; (∂/∂ (f x y z) [|x y z|]) +; [|(f|1 x y z) (f|2 x y z) (f|3 x y z)|]) + +;(assert-equal "Tensor ∂/∂ - case 3" +; (apply [|(∂/∂ $ x) (∂/∂ $ y)|] (f x y)) +; [|(f|1 x y) (f|2 x y)|]) + +(assert-equal "append indices with ..." + (show (let {[$A (generate-tensor 2#1 {2 2})] + [$f (lambda [%B] B..._j)]} + (f A_i))) + (show [| [| 1 1 |] [| 1 1 |] |]_i_j)) + +(assert-equal "generate_tensor by using function expr" + (letrec {[$g__ (generate-tensor + (match-lambda [integer integer] + {[[$n ,n] (function [x y z])] + [[_ _] 0]}) + {3 3})]} + (show (with-symbols {i j} (d/d g_i_j x)))) + "[| [| g_1_1|x 0 0 |] [| 0 g_2_2|x 0 |] [| 0 0 g_3_3|x |] |]") + +(assert-equal "define tensor having value of function expr" + (letrec {[$g__ [| [| (function [x y z]) 0 0 |] [| 0 (function [x y z]) 0 |] [| 0 0 (function [x y z]) |] |]]} + (show (with-symbols {i j} (d/d g_i_j x)))) + "[| [| g_1_1|x 0 0 |] [| 0 g_2_2|x 0 |] [| 0 0 g_3_3|x |] |]") diff --git a/test/primitive.egi b/test/primitive.egi new file mode 100644 --- /dev/null +++ b/test/primitive.egi @@ -0,0 +1,15 @@ +(assert-equal "less than predicate" + [(lt? 0.1 1.0) (lt? 1.0 0.1) (lt? 1.0 1.0)] + [#t #f #f]) + +(assert-equal "less than or equal predicate" + [(lte? 0.1 1.0) (lte? 1.0 0.1) (lte? 1.0 1.0)] + [#t #f #t]) + +(assert-equal "greater than predicate" + [(gt? 0.1 1.0) (gt? 1.0 0.1) (gt? 1.0 1.0)] + [#f #t #f]) + +(assert-equal "greater than or equal predicate" + [(gte? 0.1 1.0) (gte? 1.0 0.1) (gte? 1.0 1.0)] + [#f #t #t]) diff --git a/test/syntax.egi b/test/syntax.egi new file mode 100644 --- /dev/null +++ b/test/syntax.egi @@ -0,0 +1,451 @@ +;;;;; +;;;;; Syntax Test +;;;;; + +;;; +;;; Primitive Data +;;; +(assert-equal "char literal" + c#a + c#a) + +(assert-equal "string literal" + "abc\n" + "abc\n") + +(assert-equal "bool literal" + [#t #f] + [#t #f]) + +(assert-equal "integer literal" + [1 0 -100 (+ 1 -100)] + [1 0 -100 -99]) + +(assert-equal "rational number" + [(/ 10 3) (/ 10 20) (/ -1 2)] + [(/ 10 3) (/ 1 2) (/ -1 2)]) + +(assert-equal "float literal" + [1.0 0.0 -100.012001 (+ 1.0 2)] + [1.0 0.0 -100.012001 3.0]) + +(assert-equal "inductive data literal" + + ) + +(assert-equal "tuple literal" + [1 2 3] + [1 2 3]) + +(assert-equal "singleton tuple literal" + [1] + 1) + +(assert-equal "collection literal" + {1 @{2 3 @{@{4} 5}} 6} + {1 2 3 4 5 6}) + +;;; +;;; Basic Sytax +;;; +(assert-equal "if" + (if #t #t #f) + #t) + +(assert-equal "if" + (if #f #t #f) + #f) + +(assert-equal "let binding" + (let {[$t [1 2]]} + (let {[[$x $y] t]} + (+ x y))) + 3) + +(assert-equal "let* binding" + (let* {[$x 1] [$y (+ x 1)]} y) + 2) + +(assert-equal "letrec binding" + (letrec {[[$x $y] t] + [$t [1 2]]} + (+ x y)) + 3) + +(assert-equal "mutual recursion" + (letrec {[$even? (lambda [$n] + (if (eq? n 0) #t (odd? (- n 1))))] + [$odd? (lambda [$n] + (if (eq? n 0) #f (even? (- n 1))))]} + (even? 10)) + #t) + +(assert-equal "lambda and application" + ((lambda [$x] (+ 1 x)) 10) + 11) + +(assert-equal "placeholder" + ((+ $ 1) 10) + 11) + +(assert-equal "indexed placeholder" + ((+ $1 $1) 10) + 20) + +(assert-equal "indexed placeholder2" + ((- $2 $1) 10 20) + 10) + +;;; +;;; Pattern-Matching +;;; +(assert-equal "match" + (match 1 integer + {[,0 0] + [$x (+ 10 x)]}) + 11) + +(assert-equal "match-all" + (match-all {1 2 3} (list integer) + [ [x xs]]) + {[1 {2 3}]}) + +(assert-equal "match-all-multi" + (match-all {1 2 3} (multiset integer) + {[> [x (+ x 1)]] + [> [x (+ x 2)]]}) + {[1 2] [2 3] [1 3]}) + +(assert-equal "match-lambda" + (letrec {[$count (match-lambda (list something) + {[ 0] + [ (+ (count xs) 1)]})]} + (count {1 2 3})) + 3) + +(assert-equal "match-all-lambda" + ((match-all-lambda (list something) [> x]) {1 2 3}) + {1 2 3}) + +(assert-equal "match-all-lambda-multi" + ((match-all-lambda (multiset something) + {[> [x (+ x 1)]] + [> [x (+ x 2)]]}) {1 2 3}) + {[1 2] [2 3] [1 3]}) + +(assert-equal "pattern variable" + (match 1 something + {[$x x]}) + 1) + +(assert "value pattern" + (match 1 integer + {[,1 #t]})) + +(assert "and pattern" + (match {1 2 3} (list integer) + {[(& ) #t]})) + +(assert "and pattern" + (match {1 2 3} (list integer) + {[(& ) #f] + [_ #t]})) + +(assert "and pattern" + (match #t something + {[(&) #t]})) + +(assert "or pattern" + (match {1 2 3} (list integer) + {[(| ) #t]})) + +(assert "or pattern" + (match {1 2 3} (list integer) + {[(| ) #f] + [_ #t]})) + +(assert "or pattern" + (match #t something + {[(|) #f] + [_ #t]})) + +;(assert-equal "ordered or pattern" +; (match {1 2 3 4 5} (list integer) {[ xs]}) +; {4 5}) + +;(assert-equal "ordered or pattern" +; (let {[$x [| 1 2 3 |]]} +; (match-all {2 1 3} (multiset integer) +; [>>> (map 1#y_%1 (between 1 3))])) +; {{2 3 1} {3 1 2} {2 1 3} {3 2 1} {1 3 2} {1 2 3}}) + +;(assert "ordered or pattern" +; (match {1 2 3} (list integer) +; {[(|* ) #f] +; [_ #t]})) + +(assert "not pattern" + (match 1 integer + {[!,1 #f] + [!,2 #t]})) + +(assert-equal "not pattern" + (match-all {1 2 2 3 3 3} (multiset integer) + [> n]) + {1}) + +(assert-equal "later pattern" + (match-all {1 1 2} (list integer) + [> n]) + {1}) + +(assert "predicate pattern" + (match {1 2 3} (list integer) + {[ #t]})) + +(assert "predicate pattern" + (match {1 2 3} (list integer) + {[ #f] + [_ #t]})) + +(assert-equal "indexed pattern variable" + (match 23 (mod 10) {[$a_1 a]}) + {| [1 23] |}) + +(assert-equal "seq pattern" + (match-all {1 2 3 2 4 3 5} (list integer) + [{> + !> } + x]) + {1 2 3 4 5}) + +;(assert-equal "dfs pattern 1" +; (take 10 (match-all nats (set integer) +; [(dfs >>) [m n l]])) +; {[1 1 1] [1 1 2] [1 1 3] [1 1 4] [1 1 5] [1 1 6] [1 1 7] [1 1 8] [1 1 9] [1 1 10]}) + +;(assert-equal "dfs pattern 2" +; (take 10 (match-all nats (set integer) +; [>)> [m n l]])) +; {[1 1 1] [2 1 1] [3 1 1] [4 1 1] [5 1 1] [6 1 1] [7 1 1] [8 1 1] [9 1 1] [10 1 1]}) + +;(assert-equal "dfs pattern 3" +; (match-all (between 1 3) (set integer) +; [)>> [m n l]]) +; {[1 1 1] [1 2 1] [2 1 1] [1 3 1] [2 2 1] [3 1 1] [2 3 1] [3 2 1] [3 3 1] [1 1 2] [1 2 2] [2 1 2] [1 3 2] [2 2 2] [3 1 2] [2 3 2] [3 2 2] [3 3 2] [1 1 3] [1 2 3] [2 1 3] [1 3 3] [2 2 3] [3 1 3] [2 3 3] [3 2 3] [3 3 3]}) + +;(assert-equal "dfs and bfs pattern 1" +; (take 10 (match-all nats (set integer) +; [(dfs >)>) [m n l]])) +; {[1 1 1] [1 1 2] [1 2 1] [1 1 3] [1 2 2] [1 3 1] [1 1 4] [1 2 3] [1 3 2] [1 4 1]}) + +;(assert-equal "dfs and bfs pattern 2" +; (take 10 (match-all nats (set integer) +; [(dfs )>>) [m n l]])) +; {[1 1 1] [1 1 2] [1 1 3] [1 1 4] [1 1 5] [1 1 6] [1 1 7] [1 1 8] [1 1 9] [1 1 10]}) + +(assert "loop pattern" + (match {3 2 1} (list integer) + {[(loop $i [1 {3} _] ) #t]})) + +(assert-equal "double loop pattern" + (match {{1 2 3} {4 5 6} {7 8 9}} (list (list integer)) + {[(loop $i [1 {3} _] + + ) ...> + ) + n]}) + {|[1 {|[1 1] [2 2] [3 3]|}] [2 {|[1 4] [2 5] [3 6]|}] [3 {|[1 7] [2 8] [3 9]|}]|}) + +(assert-equal "let pattern" + (match {1 2 3} (list integer) + {[(let {[$a 42]} _) a]}) + 42) + +(assert-equal "let pattern" + (match {1 2 3} (list integer) + {[ [x xs]]}) + [1 { 2 3 }]) + +(assert-equal "let pattern" + (match {1 2 3} (list integer) + {[(& $a (let {[$n (length a)]} _)) [a n]]}) + [{1 2 3} 3]) + +(assert-equal "tuple patterns" + (match-all [1 [2 3]] [integer [integer integer]] + [[$m [$n $w]] [m n w]]) + {[1 2 3]}) + +(assert-equal "pattern function call" + (letrec {[$twin (pattern-function [$pat1 $pat2] + >) + ]} + (match {1 1 1 2 3} (list integer) + {[(twin $n $ns) [n ns]]})) + [1 {1 2 3}]) + +(assert-equal "recursive pattern function call" + (letrec {[$repeat (pattern-function [$pat] + (| + )) + ]} + (match {1 1 1 1} (list integer) + {[(repeat $n) n]})) + 1) + +(assert-equal "loop pattern in pattern function" + (letrec {[$comb (lambda [$n] + (pattern-function [$p] + (loop $i [1 {n} _] + > + _))) + ]} + (match-all {1 2 3 4 5} (list integer) + [((comb 2) $n) n])) + {{|[1 1] [2 2]|} {|[1 1] [2 3]|} {|[1 2] [2 3]|} {|[1 1] [2 4]|} {|[1 2] [2 4]|} {|[1 3] [2 4]|} {|[1 1] [2 5]|} {|[1 2] [2 5]|} {|[1 3] [2 5]|} {|[1 4] [2 5]|}}) + +(assert-equal "pairs of 2 natural numbers" + (take 10 (match-all nats (set integer) + [> [m n]])) + {[1 1] [1 2] [2 1] [1 3] [2 2] [3 1] [1 4] [2 3] [3 2] [4 1]}) + +(assert-equal "pairs of 2 different natural numbers" + (take 10 (match-all nats (list integer) + [>>> [m n]])) + {[1 2] [1 3] [2 3] [1 4] [2 4] [3 4] [1 5] [2 5] [3 5] [4 5]}) + +(define $tree + (lambda [$a] + (algebraic-data-matcher + { }))) + +(define $tree-insert + (lambda [$n $t] + (match t (tree integer) + {[ n >] + [ + (match (compare n m) ordering + {[ ] + [ ] + [ ]})]}))) + +(define $tree-member? + (lambda [$n $t] + (match t (tree integer) + {[ #f] + [ + (match (compare n m) ordering + {[ (tree-member? n t1)] + [ #t] + [ (tree-member? n t2)]})]}))) + +(assert-equal "tree set using algebraic-data-matcher" + (let {[$t (foldr tree-insert {4 1 2 4 3})]} + [(tree-member? 1 t) (tree-member? 0 t)]) + [#t #f]) + +(assert-equal "tuple pattern" + (match-all {[1 1] [2 2]} (multiset [integer integer]) [ x]) + {1 2}) + + +;;; +;;; Array +;;; + +(assert-equal "array-literal" + (| 1 2 3 4 5 |) + (| 1 2 3 4 5 |) + ) + +(assert-equal "empty array literal" + (||) + (||) + ) + +(assert-equal "generate-array" + (generate-array (+ $ 100) [3 5])_4 + 104 + ) + +(assert-equal "array-bounds - case 1" + (array-bounds (| 1 2 3 |)) + [1 3] + ) + +(assert-equal "array-bounds - case 2" + (array-bounds (generate-array (+ $ 100) [3 5])) + [3 5] + ) + +(assert-equal "array-ref" + (array-ref (| 1 2 3 4 5 |) 3) + 3) + +;;; +;;; Tensor +;;; +(assert-equal "generate-tensor - case 1" + (generate-tensor kronecker-delta {3}) + [| 1 1 1 |]) + +(assert-equal "generate-tensor - case 2" + (generate-tensor kronecker-delta { 2 2 2 2 }) + (tensor {2 2 2 2} {1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1} )) + +;;; +;;; Hash +;;; +(assert-equal "hash-literal" + {| [1 11] [2 12] [3 13] [4 14] [5 15] |} + {| [1 11] [2 12] [3 13] [4 14] [5 15] |} + ) + +(assert-equal "empty hash-literal" + {| |} + {| |} + ) + +(assert-equal "hash access" + {| [1 11] [2 12] [3 13] [4 14] [5 15] |}_3 + 13 + ) + +;(assert-equal "string hash access" +; {| ["1" 11] ["2" 12] ["3" 13] ["4" 14] ["5" 15] |}_"3" +; 13 +; ) + +;;; +;;; Partial Application +;;; +(assert-equal "partial application '$'" + ((+ $ $) 1 2) + 3) + +(assert-equal "partial application '$' with index" + ((- $2 $1) 1 2) + 1) + +(assert-equal "partial application '#'" + (2#(+ (* 10 %1) %2) 1 2) + 12) + +(assert-equal "recursive partial application '#'" + (take 10 (1#{%1 @(%0 (* %1 2))} 2)) + {2 4 8 16 32 64 128 256 512 1024}) + +(assert-equal "double inverted index" + (let {[$f (lambda [*$x *$y] (+ x y))]} + [(f [|1 2 3|]_i [|10 20 30|]_j)]) + [[| [| 11 21 31 |] [| 12 22 32 |] [| 13 23 33 |] |]~i~j]) + +(assert-equal "single inverted index" + (let {[$f (lambda [$x *$y] (+ x y))]} + [(f [|1 2 3|]_i [|10 20 30|]_j)]) + [[| [| 11 21 31 |] [| 12 22 32 |] [| 13 23 33 |] |]_i~j]) +