egison 4.0.0 → 4.0.1
raw patch · 41 files changed
+1177/−995 lines, 41 files
Files
- egison.cabal +16/−2
- hs-src/Interpreter/egison.hs +3/−3
- hs-src/Language/Egison.hs +10/−10
- hs-src/Language/Egison/AST.hs +4/−5
- hs-src/Language/Egison/CmdOptions.hs +2/−2
- hs-src/Language/Egison/Core.hs +68/−78
- hs-src/Language/Egison/Data.hs +51/−47
- hs-src/Language/Egison/Desugar.hs +38/−38
- hs-src/Language/Egison/IState.hs +7/−56
- hs-src/Language/Egison/MathExpr.hs +59/−36
- hs-src/Language/Egison/MathOutput.hs +10/−333
- hs-src/Language/Egison/Parser.hs +15/−11
- hs-src/Language/Egison/Parser/NonS.hs +23/−19
- hs-src/Language/Egison/Parser/SExpr.hs +57/−18
- hs-src/Language/Egison/Pretty.hs +62/−108
- hs-src/Language/Egison/PrettyMath/AST.hs +111/−0
- hs-src/Language/Egison/PrettyMath/AsciiMath.hs +57/−0
- hs-src/Language/Egison/PrettyMath/Latex.hs +83/−0
- hs-src/Language/Egison/PrettyMath/Mathematica.hs +67/−0
- hs-src/Language/Egison/PrettyMath/Maxima.hs +52/−0
- hs-src/Language/Egison/Primitives.hs +37/−16
- hs-src/Language/Egison/Tensor.hs +39/−31
- hs-src/Tool/translator.hs +23/−23
- lib/core/assoc.egi +2/−2
- lib/core/io.egi +39/−46
- lib/core/random.egi +2/−2
- lib/math/common/functions.egi +8/−0
- lib/math/normalize.egi +1/−0
- sample/ioRef.egi +11/−0
- sample/sat/cdcl.egi +2/−2
- sample/tree.egi +41/−0
- test/Test.hs +4/−3
- test/lib/core/assoc.egi +73/−0
- test/lib/core/base.egi +1/−2
- test/lib/core/collection.egi +25/−37
- test/lib/core/maybe.egi +6/−13
- test/lib/core/number.egi +22/−23
- test/lib/core/order.egi +13/−5
- test/lib/core/string.egi +4/−4
- test/primitive.egi +18/−20
- test/syntax.egi +11/−0
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 4.0.0+Version: 4.0.1 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.@@ -55,7 +55,7 @@ Maintainer: Satoshi Egi <egi@egison.org> Category: Compilers/Interpreters Build-type: Simple-Cabal-version: >=1.8+Cabal-version: 2.0 Extra-Source-Files: benchmark/Benchmark.hs @@ -71,6 +71,7 @@ location: https://github.com/egison/egison.git Library+ default-language: Haskell2010 Build-Depends: base >= 4.7 && < 5 , array@@ -114,13 +115,20 @@ Language.Egison.Parser.SExpr Language.Egison.Parser.NonS Language.Egison.Pretty+ Language.Egison.PrettyMath.AST+ Language.Egison.PrettyMath.AsciiMath+ Language.Egison.PrettyMath.Latex+ Language.Egison.PrettyMath.Mathematica+ Language.Egison.PrettyMath.Maxima Language.Egison.Primitives Language.Egison.Tensor Language.Egison.Types Other-modules: Paths_egison+ autogen-modules: Paths_egison ghc-options: -O3 -Wall -Wno-name-shadowing -Wno-incomplete-patterns Test-Suite test+ default-language: Haskell2010 Type: exitcode-stdio-1.0 Hs-Source-Dirs: test Main-Is: Test.hs@@ -135,8 +143,10 @@ , test-framework-hunit , filepath Other-modules: Paths_egison+ autogen-modules: Paths_egison Benchmark benchmark+ default-language: Haskell2010 Type: exitcode-stdio-1.0 Hs-Source-Dirs: benchmark Main-Is: Benchmark.hs@@ -148,8 +158,10 @@ , transformers , mtl Other-modules: Paths_egison+ autogen-modules: Paths_egison Executable egison+ default-language: Haskell2010 Main-is: egison.hs Build-depends: egison@@ -174,9 +186,11 @@ Build-Depends: semigroups Hs-Source-Dirs: hs-src/Interpreter Other-modules: Paths_egison+ autogen-modules: Paths_egison ghc-options: -O3 -threaded -eventlog -rtsopts -Wall -Wno-name-shadowing Executable egison-translate+ default-language: Haskell2010 Main-is: translator.hs Build-depends: egison
hs-src/Interpreter/egison.hs view
@@ -65,7 +65,7 @@ let (sopts, copts) = unzip (optFieldInfo opts) sopts' = "[" ++ intercalate ", " sopts ++ "]" copts' = "[" ++ intercalate ", " copts ++ "]"- expr = "load \"lib/core/shell.segi\"\n"+ expr = "load \"lib/core/shell.egi\"\n" ++ "execute (let SH.input := SH.genInput " ++ sopts' ++ " " ++ copts' ++ "\n" ++ " in each (\\x -> print (" ++ if optTsvOutput opts then "showTsv" else "show" ++ " x)) (" ++ sub ++ " SH.input))" in executeEgisonTopExpr opts env expr@@ -115,7 +115,7 @@ settings :: MonadIO m => FilePath -> Settings m settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home </> ".egison_history"), autoAddHistory = False } - loop :: StateT [(Var, EgisonExpr)] EgisonM Env -> IO ()+ loop :: StateT [(Var, EgisonExpr)] EvalM Env -> IO () loop st = (do home <- getHomeDirectory input <- liftIO $ runInputT (settings home) $ getEgisonExpr opts@@ -128,7 +128,7 @@ putStrLn "error: No IO support" loop st (_, Just topExpr) -> do- result <- liftIO $ fromEgisonM (desugarTopExpr topExpr >>= evalTopExpr' opts st)+ result <- liftIO $ fromEvalM (desugarTopExpr topExpr >>= evalTopExpr' opts st) case result of Left err -> liftIO (print err) >> loop st Right (Nothing, st') -> loop st'
hs-src/Language/Egison.hs view
@@ -47,14 +47,14 @@ version :: Version version = P.version -evalTopExprs :: EgisonOpts -> Env -> [EgisonTopExpr] -> EgisonM Env+evalTopExprs :: EgisonOpts -> Env -> [EgisonTopExpr] -> EvalM Env evalTopExprs opts env exprs = do (bindings, rest) <- collectDefs opts exprs [] [] env <- recursiveBind env bindings forM_ rest $ evalTopExpr opts env return env -evalTopExpr :: EgisonOpts -> Env -> EgisonTopExpr -> EgisonM Env+evalTopExpr :: EgisonOpts -> Env -> EgisonTopExpr -> EvalM Env evalTopExpr opts env topExpr = do ret <- evalTopExpr' opts (StateT $ \defines -> (, defines) <$> recursiveBind env defines) topExpr case fst ret of@@ -67,35 +67,35 @@ -- |eval an Egison expression evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue)-evalEgisonExpr env expr = fromEgisonM $ evalExprDeep env expr+evalEgisonExpr env expr = fromEvalM $ evalExprDeep env expr -- |eval an Egison top expression evalEgisonTopExpr :: EgisonOpts -> Env -> EgisonTopExpr -> IO (Either EgisonError Env)-evalEgisonTopExpr opts env exprs = fromEgisonM $ evalTopExpr opts env exprs+evalEgisonTopExpr opts env exprs = fromEvalM $ evalTopExpr opts env exprs -- |eval Egison top expressions evalEgisonTopExprs :: EgisonOpts -> Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)-evalEgisonTopExprs opts env exprs = fromEgisonM $ evalTopExprs opts env exprs+evalEgisonTopExprs opts env exprs = fromEvalM $ evalTopExprs opts env exprs -- |eval an Egison expression. Input is a Haskell string. runEgisonExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError EgisonValue) runEgisonExpr opts env input =- fromEgisonM $ readExpr (optSExpr opts) input >>= evalExprDeep env+ fromEvalM $ readExpr (optSExpr opts) 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 =- fromEgisonM $ readTopExpr (optSExpr opts) input >>= evalTopExpr opts env+ fromEvalM $ readTopExpr (optSExpr opts) 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' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EvalM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EvalM Env)) runEgisonTopExpr' opts st input =- fromEgisonM $ readTopExpr (optSExpr opts) input >>= evalTopExpr' opts st+ fromEvalM $ readTopExpr (optSExpr opts) 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 =- fromEgisonM $ readTopExprs (optSExpr opts) input >>= evalTopExprs opts env+ fromEvalM $ readTopExprs (optSExpr opts) input >>= evalTopExprs opts env -- |load an Egison file loadEgisonFile :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env)
hs-src/Language/Egison/AST.hs view
@@ -78,7 +78,6 @@ | LambdaExpr [Arg] EgisonExpr | MemoizedLambdaExpr [String] EgisonExpr | CambdaExpr String EgisonExpr- | ProcedureExpr [String] EgisonExpr | PatternFunctionExpr [String] EgisonPattern | IfExpr EgisonExpr EgisonExpr EgisonExpr@@ -102,15 +101,15 @@ | DoExpr [BindingExpr] EgisonExpr | IoExpr EgisonExpr - | UnaryOpExpr String EgisonExpr- | BinaryOpExpr Infix EgisonExpr EgisonExpr+ | PrefixExpr String EgisonExpr+ | InfixExpr Infix EgisonExpr EgisonExpr | SectionExpr Infix (Maybe EgisonExpr) (Maybe EgisonExpr) -- There cannot be 'SectionExpr op (Just _) (Just _)' | SeqExpr EgisonExpr EgisonExpr | ApplyExpr EgisonExpr EgisonExpr | CApplyExpr EgisonExpr EgisonExpr- | PartialExpr Integer EgisonExpr- | PartialVarExpr Integer+ | AnonParamFuncExpr Integer EgisonExpr+ | AnonParamExpr Integer | GenerateTensorExpr EgisonExpr EgisonExpr | TensorExpr EgisonExpr EgisonExpr
hs-src/Language/Egison/CmdOptions.hs view
@@ -79,12 +79,12 @@ <> long "substitute" <> metavar "EXPR" <> help "Operate input in tsv format as infinite stream"))- <*> optional ((\s -> "(map " ++ s ++ " $)") <$> strOption+ <*> optional ((\s -> "1#(map " ++ s ++ " %1)") <$> strOption (short 'm' <> long "map" <> metavar "EXPR" <> help "Operate input in tsv format line by line"))- <*> optional ((\s -> "(filter " ++ s ++ " $)") <$> strOption+ <*> optional ((\s -> "1#(filter " ++ s ++ " %1)") <$> strOption (short 'f' <> long "filter" <> metavar "EXPR"
hs-src/Language/Egison/Core.hs view
@@ -53,7 +53,7 @@ import Language.Egison.CmdOptions import Language.Egison.Data import Language.Egison.MList-import Language.Egison.IState (MonadFresh(..))+import Language.Egison.IState (MonadEval(..)) import Language.Egison.MathExpr import Language.Egison.Parser import Language.Egison.Pretty@@ -63,7 +63,7 @@ -- Evaluator -- -collectDefs :: EgisonOpts -> [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr])+collectDefs :: EgisonOpts -> [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EvalM ([(Var, EgisonExpr)], [EgisonTopExpr]) collectDefs opts (expr:exprs) bindings rest = case expr of Define name expr -> collectDefs opts exprs ((name, expr) : bindings) rest@@ -82,7 +82,7 @@ InfixDecl{} -> collectDefs opts exprs bindings rest collectDefs _ [] bindings rest = return (bindings, reverse rest) -evalTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> EgisonTopExpr -> EgisonM (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env)+evalTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EvalM Env -> EgisonTopExpr -> EvalM (Maybe String, StateT [(Var, EgisonExpr)] EvalM Env) evalTopExpr' _ st (Define name expr) = return (Nothing, withStateT (\defines -> (name, expr):defines) st) evalTopExpr' _ _ DefineWithIndices{} = throwError =<< EgisonBug "should not reach here (desugared)" <$> getFuncNameStack evalTopExpr' _ st (Redefine name expr) = return (Nothing, mapStateT (>>= \(env, defines) -> (, defines) <$> recursiveRebind env (name, expr)) st)@@ -109,7 +109,7 @@ return (Nothing, withStateT (\defines -> bindings ++ defines) st) evalTopExpr' _ st InfixDecl{} = return (Nothing, st) -evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData+evalExpr :: Env -> EgisonExpr -> EvalM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c evalExpr _ (StringExpr s) = return . Value $ toEgison s evalExpr _ (BoolExpr b) = return . Value $ Bool b@@ -131,17 +131,17 @@ evalExpr env (VarExpr var@(Var [name@(c:_)] [])) | isUpper c = refVar' env var >>= evalRef where- refVar' :: Env -> Var -> EgisonM ObjectRef+ refVar' :: Env -> Var -> EvalM ObjectRef refVar' env var = maybe (newEvaluatedObjectRef (Value (InductiveData name []))) return (refVar env var) evalExpr env (VarExpr name) = refVar' env name >>= evalRef where- refVar' :: Env -> Var -> EgisonM ObjectRef- refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" $ prettyS var))) return+ refVar' :: Env -> Var -> EvalM ObjectRef+ refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" $ prettyStr var))) return (refVar env var) -evalExpr env (PartialVarExpr n) = evalExpr env (stringToVarExpr ("::" ++ show n))+evalExpr env (AnonParamExpr n) = evalExpr env (stringToVarExpr ("::" ++ show n)) evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] evalExpr env (InductiveDataExpr name exprs) =@@ -158,7 +158,7 @@ innersSeq <- liftIO $ newIORef $ Sq.fromList inners' return $ Intermediate $ ICollection innersSeq where- fromInnerExpr :: InnerExpr -> EgisonM Inner+ fromInnerExpr :: InnerExpr -> EvalM Inner fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr @@ -171,7 +171,7 @@ mapM toTensor (zipWith f whnfs indices) >>= tConcat' >>= fromTensor _ -> fromTensor (Tensor [n] (V.fromList whnfs) []) where- evalWithIndex :: EgisonExpr -> Integer -> EgisonM WHNFData+ evalWithIndex :: EgisonExpr -> Integer -> EvalM WHNFData evalWithIndex expr index = evalExpr env' expr where env' = case maybe_vwi of@@ -189,12 +189,12 @@ fn' = case maybe_vwi of Nothing -> fn Just (VarWithIndices name indices) ->- symbolScalarData' "" $ prettyS (VarWithIndices name (zipWith changeIndex indices ms))+ symbolScalarData' "" $ prettyStr (VarWithIndices name (zipWith changeIndex indices ms)) g x _ = x evalExpr env (TensorExpr nsExpr xsExpr) = do nsWhnf <- evalExpr env nsExpr- ns <- (fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer]+ ns <- (fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EvalM [Integer] xsWhnf <- evalExpr env xsExpr xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef if product ns == toInteger (length xs)@@ -217,7 +217,7 @@ let keys' = map (\case IntKey i -> i) keys return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs where- makeHashKey :: WHNFData -> EgisonM EgisonHashKey+ makeHashKey :: WHNFData -> EvalM EgisonHashKey makeHashKey (Value val) = case val of ScalarData _ -> IntKey <$> fromEgison val@@ -249,10 +249,10 @@ refArray tensor (map (ScalarData . extractIndex) js2) return ret -- TODO: refactor where- evalIndex :: Index EgisonExpr -> EgisonM (Index EgisonValue)+ evalIndex :: Index EgisonExpr -> EvalM (Index EgisonValue) evalIndex index = traverse (evalExprDeep env) index - evalIndexToScalar :: Index EgisonExpr -> EgisonM (Index ScalarData)+ evalIndexToScalar :: Index EgisonExpr -> EvalM (Index ScalarData) evalIndexToScalar index = traverse ((extractScalar =<<) . evalExprDeep env) index evalExpr env (SubrefsExpr override expr jsExpr) = do@@ -301,19 +301,17 @@ ScalarArg _ -> throwError =<< EgisonBug "scalar-arg remained" <$> getFuncNameStack) names return . Value $ Func Nothing env names' expr -evalExpr env (PartialExpr n expr) = return . Value $ PartialFunc env n expr+evalExpr env (AnonParamFuncExpr n expr) = return . Value $ AnonParamFunc env n expr evalExpr env (CambdaExpr name expr) = return . Value $ CFunc Nothing env name expr -evalExpr env (ProcedureExpr names expr) = return . Value $ Proc Nothing env names expr- evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern evalExpr (Env _ Nothing) (FunctionExpr _) = throwError $ Default "function symbol is not bound to a variable" evalExpr env@(Env _ (Just name)) (FunctionExpr args) = do args' <- mapM (evalExprDeep env) args >>= mapM extractScalar- return . Value $ ScalarData (SingleTerm 1 [(FunctionData (symbolScalarData' "" (prettyS name)) (map (symbolScalarData' "" . prettyS) args) args' [], 1)])+ return . Value $ ScalarData (SingleTerm 1 [(FunctionData (symbolScalarData' "" (prettyStr name)) (map (symbolScalarData' "" . prettyStr') args) args' [], 1)]) evalExpr env (IfExpr test expr expr') = do test <- evalExpr env test >>= fromWHNF@@ -322,7 +320,7 @@ evalExpr env (LetExpr bindings expr) = mapM extractBindings bindings >>= flip evalExpr expr . extendEnv env . concat where- extractBindings :: BindingExpr -> EgisonM [Binding]+ extractBindings :: BindingExpr -> EvalM [Binding] extractBindings ([name], expr) = case expr of FunctionExpr _ ->@@ -384,7 +382,7 @@ isTmpSymbol symId (Superscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id isTmpSymbol symId (SupSubscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id isTmpSymbol symId (Userscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id- removeTmpScripts :: HasTensor a => String -> Tensor a -> EgisonM (Tensor a)+ removeTmpScripts :: HasTensor a => String -> Tensor a -> EvalM (Tensor a) removeTmpScripts symId (Tensor s xs is) = do let (ds, js) = partition (isTmpSymbol symId) is Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is)@@ -413,7 +411,7 @@ matcher <- evalExpr env matcher >>= evalMatcherWHNF f matcher target >>= fromMList where- fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData+ fromMList :: MList EvalM WHNFData -> EvalM WHNFData fromMList MNil = return . Value $ Collection Sq.empty fromMList (MCons val m) = do head <- IElement <$> newEvaluatedObjectRef val@@ -528,11 +526,11 @@ evalExpr env (GenerateTensorExpr fnExpr shapeExpr) = do shape <- evalExpr env shapeExpr >>= collectionToList- ns <- mapM fromEgison shape :: EgisonM Shape+ ns <- mapM fromEgison shape :: EvalM Shape xs <- mapM (indexToWHNF env . map toEgison) (enumTensorIndices ns) fromTensor (Tensor ns (V.fromList xs) []) where- indexToWHNF :: Env -> [EgisonValue] {- index -} -> EgisonM WHNFData+ indexToWHNF :: Env -> [EgisonValue] {- index -} -> EvalM WHNFData indexToWHNF (Env frame maybe_vwi) ms = do let env' = maybe env (\(VarWithIndices name indices) -> Env frame $ Just $ VarWithIndices name $ zipWith changeIndex indices ms) maybe_vwi fn <- evalExpr env' fnExpr@@ -559,7 +557,7 @@ Value <$> (tMap (applyFunc' env fn) t >>= fromTensor) _ -> applyFunc env fn whnf where- applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue+ applyFunc' :: Env -> WHNFData -> EgisonValue -> EvalM EgisonValue applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF evalExpr env (TensorMap2Expr fnExpr t1Expr t2Expr) = do@@ -593,9 +591,9 @@ return $ Intermediate (ITensor (Tensor ns ys js)) _ -> applyFunc'' env fn whnf1 whnf2 where- applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue+ applyFunc' :: Env -> WHNFData -> EgisonValue -> EvalM EgisonValue applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF- applyFunc'' :: Env -> WHNFData -> WHNFData -> WHNFData -> EgisonM WHNFData+ applyFunc'' :: Env -> WHNFData -> WHNFData -> WHNFData -> EvalM WHNFData applyFunc'' env fn x y = do xRef <- newEvaluatedObjectRef x yRef <- newEvaluatedObjectRef y@@ -606,10 +604,10 @@ evalExpr _ UndefinedExpr = return $ Value Undefined evalExpr _ expr = throwError =<< NotImplemented ("evalExpr for " ++ show expr) <$> getFuncNameStack -evalExprDeep :: Env -> EgisonExpr -> EgisonM EgisonValue+evalExprDeep :: Env -> EgisonExpr -> EvalM EgisonValue evalExprDeep env expr = evalExpr env expr >>= evalWHNF -evalRef :: ObjectRef -> EgisonM WHNFData+evalRef :: ObjectRef -> EvalM WHNFData evalRef ref = do obj <- liftIO $ readIORef ref case obj of@@ -619,7 +617,7 @@ writeObjectRef ref val return val -evalRefDeep :: ObjectRef -> EgisonM EgisonValue+evalRefDeep :: ObjectRef -> EvalM EgisonValue evalRefDeep ref = do obj <- liftIO $ readIORef ref case obj of@@ -633,7 +631,7 @@ writeObjectRef ref $ Value val return val -evalWHNF :: WHNFData -> EgisonM EgisonValue+evalWHNF :: WHNFData -> EvalM EgisonValue evalWHNF (Value val) = return val evalWHNF (Intermediate (IInductiveData name refs)) = InductiveData name <$> mapM evalRefDeep refs@@ -659,7 +657,7 @@ valuetoTensor2 :: WHNFData -> Tensor WHNFData valuetoTensor2 (Intermediate (ITensor t)) = t -applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData+applyFunc :: Env -> WHNFData -> WHNFData -> EvalM WHNFData applyFunc env (Value (TensorData (Tensor s1 t1 i1))) tds = do tds <- fromTupleWHNF tds if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s _ i))) -> length s - length i == 1) tds@@ -684,11 +682,11 @@ makeITuple (map Intermediate (ITensor (Tensor s1 t1 (i1 ++ supjs)):map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds))) >>= applyFunc env dot else throwError $ Default "applyfunc" -applyFunc _ (Value (PartialFunc env n body)) arg = do+applyFunc _ (Value (AnonParamFunc env n body)) arg = do refs <- fromTuple arg if n == fromIntegral (length refs) then evalExpr (extendEnv env $ makeBindings (map (\n -> stringToVar $ "::" ++ show n) [1..n]) refs) body- else throwError =<< ArgumentsNumWithNames ["partial"] (fromIntegral n) (length refs) <$> getFuncNameStack+ else throwError =<< ArgumentsNumWithNames ["anonymous parameter function"] (fromIntegral n) (length refs) <$> getFuncNameStack applyFunc _ (Value (Func (Just (Var [funcname] _)) env [name] body)) arg = do pushFuncName funcname ref <- newEvaluatedObjectRef arg@@ -711,14 +709,6 @@ if length names == length refs then evalExpr (extendEnv env $ makeBindings' names refs) body else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack-applyFunc _ (Value (Proc _ env [name] body)) arg = do- ref <- newEvaluatedObjectRef arg- evalExpr (extendEnv env $ makeBindings' [name] [ref]) body-applyFunc _ (Value (Proc _ env names body)) arg = do- refs <- fromTuple arg- if length names == length refs- then evalExpr (extendEnv env $ makeBindings' names refs) body- else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack applyFunc _ (Value (CFunc _ env name body)) arg = do refs <- fromTuple arg seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs)@@ -739,7 +729,7 @@ return (Value (ScalarData (SingleTerm 1 [(Apply fn mExprs, 1)]))) applyFunc _ whnf _ = throwError =<< TypeMismatch "function" whnf <$> getFuncNameStack -refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData+refArray :: WHNFData -> [EgisonValue] -> EvalM WHNFData refArray val [] = return val refArray (Value (IntHash hash)) (index:indices) = do key <- fromEgison index@@ -776,13 +766,13 @@ newThunk :: Env -> EgisonExpr -> Object newThunk env expr = Thunk $ evalExpr env expr -newObjectRef :: Env -> EgisonExpr -> EgisonM ObjectRef+newObjectRef :: Env -> EgisonExpr -> EvalM ObjectRef newObjectRef env expr = liftIO $ newIORef $ newThunk env expr -writeObjectRef :: ObjectRef -> WHNFData -> EgisonM ()+writeObjectRef :: ObjectRef -> WHNFData -> EvalM () writeObjectRef ref val = liftIO . writeIORef ref $ WHNF val -newEvaluatedObjectRef :: WHNFData -> EgisonM ObjectRef+newEvaluatedObjectRef :: WHNFData -> EvalM ObjectRef newEvaluatedObjectRef = liftIO . newIORef . WHNF makeBindings :: [Var] -> [ObjectRef] -> [Binding]@@ -791,7 +781,7 @@ makeBindings' :: [String] -> [ObjectRef] -> [Binding] makeBindings' xs = zip (map stringToVar xs) -recursiveBind :: Env -> [(Var, EgisonExpr)] -> EgisonM Env+recursiveBind :: Env -> [(Var, EgisonExpr)] -> EvalM Env recursiveBind env bindings = do let (names, _) = unzip bindings refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr@@ -819,10 +809,10 @@ isVarWithIndices :: Var -> Bool isVarWithIndices (Var _ xs) = not $ null xs -recursiveRebind :: Env -> (Var, EgisonExpr) -> EgisonM Env+recursiveRebind :: Env -> (Var, EgisonExpr) -> EvalM Env recursiveRebind env (name, expr) = do case refVar env name of- Nothing -> throwError =<< UnboundVariable (prettyS name) <$> getFuncNameStack+ Nothing -> throwError =<< UnboundVariable (prettyStr name) <$> getFuncNameStack Just ref -> case expr of MemoizedLambdaExpr names body -> do hashRef <- liftIO $ newIORef HL.empty@@ -842,7 +832,7 @@ -- Pattern Match -- -patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match)+patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EvalM (MList EvalM Match) patternMatch pmmode env pattern target matcher = case pmmode of DFSMode -> processMStatesAllDFS (msingleton initMState)@@ -855,30 +845,30 @@ , mTrees = [MAtom pattern target matcher] } -processMStatesAllDFS :: MList EgisonM MatchingState -> EgisonM (MList EgisonM Match)+processMStatesAllDFS :: MList EvalM MatchingState -> EvalM (MList EvalM Match) processMStatesAllDFS MNil = return MNil processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS -processMStatesAllDFSForall :: MList EgisonM MatchingState -> EgisonM (MList EgisonM MatchingState)+processMStatesAllDFSForall :: MList EvalM MatchingState -> EvalM (MList EvalM MatchingState) processMStatesAllDFSForall MNil = return MNil processMStatesAllDFSForall (MCons mstate@(MState _ _ (ForallPatContext _ _ : _) _ []) ms) = MCons mstate . processMStatesAllDFSForall <$> ms processMStatesAllDFSForall (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall -processMStatesAll :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)+processMStatesAll :: [MList EvalM MatchingState] -> EvalM (MList EvalM Match) processMStatesAll [] = return MNil processMStatesAll streams = do (matches, streams') <- mapM processMStates streams >>= extractMatches . concat mappend (fromList matches) $ processMStatesAll streams' -processMStates :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]+processMStates :: MList EvalM MatchingState -> EvalM [MList EvalM MatchingState] processMStates MNil = return [] processMStates (MCons state stream) = (\x y -> [x, y]) <$> processMState state <*> stream -extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])+extractMatches :: [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState]) extractMatches = extractMatches' ([], []) where- extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])+ extractMatches' :: ([Match], [MList EvalM MatchingState]) -> [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState]) extractMatches' (xs, ys) [] = return (xs, ys) extractMatches' (xs, ys) (MCons (gatherBindings -> Just bindings) states : rest) = do states' <- states@@ -889,7 +879,7 @@ gatherBindings mstate@MState{ seqPatCtx = [], mTrees = [] } = return (mStateBindings mstate) gatherBindings _ = Nothing -processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState)+processMState :: MatchingState -> EvalM (MList EvalM MatchingState) processMState state = if nullMState state then processMState' state@@ -921,14 +911,14 @@ nullMState _ = False splitMState :: MatchingState -> (Integer, MatchingState, MatchingState) splitMState mstate@MState{ mTrees = MAtom (NotPat pattern) target matcher : trees } =- (1, mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees })+ (1, mstate { seqPatCtx = [], mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees }) splitMState mstate@MState{ mTrees = MAtom pattern target matcher : trees } = (0, mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees }) splitMState mstate@MState{ mTrees = MNode penv state' : trees } = (f, mstate { mTrees = [MNode penv state1] }, mstate { mTrees = MNode penv state2 : trees }) where (f, state1, state2) = splitMState state' -processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState)+processMState' :: MatchingState -> EvalM (MList EvalM MatchingState) --processMState' MState{ seqPatCtx = [], mTrees = [] } = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack processMState' mstate@MState{ seqPatCtx = [], mTrees = [] } = return . msingleton $ mstate -- for forall pattern used in matchAll (not matchAllDFS) @@ -986,7 +976,7 @@ processMState' (mstate { mTrees = MAtom (InductivePat name args) target matcher:trees }) NotPat _ -> throwError =<< EgisonBug "should not reach here (not-pattern)" <$> getFuncNameStack- VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ prettyS pattern+ VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ prettyStr pattern LetPat bindings' pattern' -> do b <- fmap concat (mapM extractBindings bindings')@@ -1014,7 +1004,7 @@ return . msingleton $ mstate { mTrees = MAtom (InductivePat "apply" [func, toListPat args]) target matcher:trees } LoopPat name (LoopRange start ends endPat) pat pat' -> do- startNum <- evalExpr env' start >>= fromWHNF :: (EgisonM Integer)+ startNum <- evalExpr env' start >>= fromWHNF :: (EvalM Integer) startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1) ends' <- evalExpr env' ends case ends' of@@ -1033,7 +1023,7 @@ [] -> throwError $ Default "cannot use cont pattern except in loop pattern" LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do startNumWhnf <- evalRef startNumRef- startNum <- fromWHNF startNumWhnf :: (EgisonM Integer)+ startNum <- fromWHNF startNumWhnf :: (EvalM Integer) nextNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum + 1) ends <- evalRef endsRef b <- isEmptyCollection ends@@ -1118,7 +1108,7 @@ obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef return . msingleton $ mstate { mStateBindings = (name,obj):bindings, mTrees = trees } where- updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData+ updateHash :: [Integer] -> WHNFData -> EvalM WHNFData updateHash [index] (Intermediate (IIntHash hash)) = do targetRef <- newEvaluatedObjectRef target return . Intermediate . IIntHash $ HL.insert index targetRef hash@@ -1135,17 +1125,17 @@ subst k nv ((k', v'):xs) | k == k' = (k', nv):subst k nv xs | otherwise = (k', v'):subst k nv xs subst _ _ [] = []- IndexedPat pattern _ -> throwError $ Default ("invalid indexed-pattern: " ++ prettyS pattern)+ IndexedPat pattern _ -> throwError $ Default ("invalid indexed-pattern: " ++ prettyStr pattern) TuplePat patterns -> do targets <- fromTupleWHNF target when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack let trees' = zipWith3 MAtom patterns targets (replicate (length patterns) Something) ++ trees return . msingleton $ mstate { mTrees = trees' }- _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ prettyS pattern+ _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ prettyStr pattern _ -> throwError =<< EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern) <$> getFuncNameStack inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher ->- EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher])+ EvalM ([EgisonPattern], MList EvalM ObjectRef, [Matcher]) inductiveMatch env pattern target (UserMatcher matcherEnv clauses) = foldr tryPPMatchClause failPPPatternMatch clauses where@@ -1240,13 +1230,13 @@ -- we don't need to extract call stack since detailed error information is not used throwError $ TypeMismatch "primitive value" whnf -expandCollection :: WHNFData -> EgisonM (Seq Inner)+expandCollection :: WHNFData -> EvalM (Seq Inner) expandCollection (Value (Collection vals)) = mapM (fmap IElement . newEvaluatedObjectRef . Value) vals expandCollection (Intermediate (ICollection innersRef)) = liftIO $ readIORef innersRef expandCollection val = throwError =<< TypeMismatch "collection" val <$> getFuncNameStack -isEmptyCollection :: WHNFData -> EgisonM Bool+isEmptyCollection :: WHNFData -> EvalM Bool isEmptyCollection (Value (Collection col)) = return $ Sq.null col isEmptyCollection coll@(Intermediate (ICollection innersRef)) = do inners <- liftIO $ readIORef innersRef@@ -1302,7 +1292,7 @@ extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopPatContext binding _ _ _ _) -> binding) loops -evalMatcherWHNF :: WHNFData -> EgisonM Matcher+evalMatcherWHNF :: WHNFData -> EvalM Matcher evalMatcherWHNF (Value matcher@Something) = return matcher evalMatcherWHNF (Value matcher@UserMatcher{}) = return matcher evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms@@ -1319,12 +1309,12 @@ toListPat [] = InductivePat "nil" [] toListPat (pat:pats) = InductivePat "cons" [pat, toListPat pats] -fromTuple :: WHNFData -> EgisonM [ObjectRef]+fromTuple :: WHNFData -> EvalM [ObjectRef] fromTuple (Intermediate (ITuple refs)) = return refs fromTuple (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals fromTuple whnf = return <$> newEvaluatedObjectRef whnf -fromTupleWHNF :: WHNFData -> EgisonM [WHNFData]+fromTupleWHNF :: WHNFData -> EvalM [WHNFData] fromTupleWHNF (Intermediate (ITuple refs)) = mapM evalRef refs fromTupleWHNF (Value (Tuple vals)) = return $ map Value vals fromTupleWHNF whnf = return [whnf]@@ -1333,7 +1323,7 @@ fromTupleValue (Tuple vals) = vals fromTupleValue val = [val] -fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef)+fromCollection :: WHNFData -> EvalM (MList EvalM ObjectRef) fromCollection (Value (Collection vals)) = if Sq.null vals then return MNil else fromSeq <$> mapM (newEvaluatedObjectRef . Value) vals@@ -1347,7 +1337,7 @@ return $ MCons head (fromCollection tail') fromCollection whnf = throwError =<< TypeMismatch "collection" whnf <$> getFuncNameStack -tupleToList :: WHNFData -> EgisonM [EgisonValue]+tupleToList :: WHNFData -> EvalM [EgisonValue] tupleToList whnf = do val <- evalWHNF whnf return $ tupleToList' val@@ -1355,12 +1345,12 @@ tupleToList' (Tuple vals) = vals tupleToList' val = [val] -collectionToList :: WHNFData -> EgisonM [EgisonValue]+collectionToList :: WHNFData -> EvalM [EgisonValue] collectionToList whnf = do val <- evalWHNF whnf collectionToList' val where- collectionToList' :: EgisonValue -> EgisonM [EgisonValue]+ collectionToList' :: EgisonValue -> EvalM [EgisonValue] collectionToList' (Collection sq) = return $ toList sq collectionToList' val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack @@ -1369,19 +1359,19 @@ makeTuple [x] = x makeTuple xs = Tuple xs -makeITuple :: [WHNFData] -> EgisonM WHNFData+makeITuple :: [WHNFData] -> EvalM WHNFData makeITuple [] = return $ Intermediate (ITuple []) makeITuple [x] = return x makeITuple xs = Intermediate . ITuple <$> mapM newEvaluatedObjectRef xs -makeICollection :: [WHNFData] -> EgisonM WHNFData+makeICollection :: [WHNFData] -> EvalM WHNFData makeICollection xs = do is <- mapM (\x -> IElement <$> newEvaluatedObjectRef x) xs v <- liftIO $ newIORef $ Sq.fromList is return $ Intermediate $ ICollection v -- Refer the specified tensor index with potential overriding of the index.-refTensorWithOverride :: HasTensor a => Bool -> [Index EgisonValue] -> Tensor a -> EgisonM a+refTensorWithOverride :: HasTensor a => Bool -> [Index EgisonValue] -> Tensor a -> EvalM a refTensorWithOverride override js (Tensor ns xs is) = tref js' (Tensor ns xs js') >>= toTensor >>= tContract' >>= fromTensor where
hs-src/Language/Egison/Data.hs view
@@ -60,12 +60,9 @@ , SeqPatContext (..) -- * Errors , EgisonError (..)- , liftError -- * Monads- , EgisonM (..)- , runEgisonM- , liftEgisonM- , fromEgisonM+ , EvalM (..)+ , fromEvalM , MatchM , matchFail ) where@@ -74,8 +71,8 @@ import Data.Typeable import Control.Monad.Except hiding (join)-import Control.Monad.State (get, put) import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State import Data.Foldable (toList) import Data.HashMap.Strict (HashMap)@@ -118,20 +115,20 @@ | StrHash (HashMap Text EgisonValue) | UserMatcher Env [PatternDef] | Func (Maybe Var) Env [String] EgisonExpr- | PartialFunc Env Integer EgisonExpr+ | AnonParamFunc Env Integer EgisonExpr | CFunc (Maybe Var) Env String EgisonExpr | MemoizedFunc (Maybe Var) ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr- | Proc (Maybe String) Env [String] EgisonExpr | PatternFunc Env [String] EgisonPattern | PrimitiveFunc String PrimitiveFunc- | IOFunc (EgisonM WHNFData)+ | IOFunc (EvalM WHNFData) | Port Handle+ | RefBox (IORef EgisonValue) | Something | Undefined type Matcher = EgisonValue -type PrimitiveFunc = WHNFData -> EgisonM WHNFData+type PrimitiveFunc = WHNFData -> EvalM WHNFData data EgisonHashKey = IntKey Integer@@ -153,8 +150,8 @@ tensorElems :: a -> V.Vector a tensorShape :: a -> Shape tensorIndices :: a -> [Index EgisonValue]- fromTensor :: Tensor a -> EgisonM a- toTensor :: a -> EgisonM (Tensor a)+ fromTensor :: Tensor a -> EvalM a+ toTensor :: a -> EvalM (Tensor a) undef :: a instance HasTensor EgisonValue where@@ -218,7 +215,7 @@ scalarIndexToEgison (Subscript k) = InductiveData "Sub" [ScalarData k] scalarIndexToEgison (Userscript k) = InductiveData "User" [ScalarData k] -egisonToScalarData :: EgisonValue -> EgisonM ScalarData+egisonToScalarData :: EgisonValue -> EvalM ScalarData egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2 egisonToScalarData p1@(InductiveData "Plus" _) = Div <$> egisonToPolyExpr p1 <*> return (Plus [Term 1 []]) egisonToScalarData t1@(InductiveData "Term" _) = do@@ -238,15 +235,15 @@ return $ SingleTerm 1 [s1'] egisonToScalarData val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack -egisonToPolyExpr :: EgisonValue -> EgisonM PolyExpr+egisonToPolyExpr :: EgisonValue -> EvalM PolyExpr egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts) egisonToPolyExpr val = throwError =<< TypeMismatch "math poly expression" (Value val) <$> getFuncNameStack -egisonToTermExpr :: EgisonValue -> EgisonM TermExpr+egisonToTermExpr :: EgisonValue -> EvalM TermExpr egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts) egisonToTermExpr val = throwError =<< TypeMismatch "math term expression" (Value val) <$> getFuncNameStack -egisonToSymbolExpr :: EgisonValue -> EgisonM (SymbolExpr, Integer)+egisonToSymbolExpr :: EgisonValue -> EvalM (SymbolExpr, Integer) egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do let js = toList seq js' <- mapM egisonToScalarIndex js@@ -273,7 +270,7 @@ return (FunctionData name' argnames' args' js', n') egisonToSymbolExpr val = throwError =<< TypeMismatch "math symbol expression" (Value val) <$> getFuncNameStack -egisonToScalarIndex :: EgisonValue -> EgisonM (Index ScalarData)+egisonToScalarIndex :: EgisonValue -> EvalM (Index ScalarData) egisonToScalarIndex j = case j of InductiveData "Sup" [ScalarData k] -> return (Superscript k) InductiveData "Sub" [ScalarData k] -> return (Subscript k)@@ -284,11 +281,11 @@ -- ExtractScalar -- -extractScalar :: EgisonValue -> EgisonM ScalarData+extractScalar :: EgisonValue -> EvalM ScalarData extractScalar (ScalarData mExpr) = return mExpr extractScalar val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack -extractScalar' :: WHNFData -> EgisonM ScalarData+extractScalar' :: WHNFData -> EvalM ScalarData extractScalar' (Value (ScalarData x)) = return x extractScalar' val = throwError =<< TypeMismatch "integer or string" val <$> getFuncNameStack @@ -332,13 +329,11 @@ show UserMatcher{} = "#<user-matcher>" show (Func Nothing _ args _) = "(lambda [" ++ intercalate ", " (map show args) ++ "] ...)" show (Func (Just name) _ _ _) = show name- show (PartialFunc _ n expr) = show n ++ "#" ++ show expr+ show (AnonParamFunc _ n expr) = show n ++ "#" ++ show expr show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)" show (CFunc (Just name) _ _ _) = show name show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ intercalate ", " names ++ "] ...)" show (MemoizedFunc (Just name) _ _ _ _ _) = show name- show (Proc Nothing _ names _) = "(procedure [" ++ intercalate ", " names ++ "] ...)"- show (Proc (Just name) _ _ _) = name show PatternFunc{} = "#<pattern-function>" show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">" show (IOFunc _) = "#<io-function>"@@ -351,8 +346,7 @@ isAtomic :: EgisonValue -> Bool isAtomic (InductiveData _ []) = True isAtomic (InductiveData _ _) = False-isAtomic (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = True-isAtomic (ScalarData _) = False+isAtomic (ScalarData m) = isAtom m isAtomic _ = True instance Eq EgisonValue where@@ -381,7 +375,7 @@ -- class EgisonData a where toEgison :: a -> EgisonValue- fromEgison :: EgisonValue -> EgisonM a+ fromEgison :: EgisonValue -> EvalM a instance EgisonData Char where toEgison = Char@@ -455,6 +449,11 @@ return (x', y', z', w') fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack +instance EgisonData (IORef EgisonValue) where+ toEgison = RefBox+ fromEgison (RefBox ref) = return ref+ fromEgison val = throwError =<< TypeMismatch "ioRef" (Value val) <$> getFuncNameStack+ -- -- Internal Data --@@ -463,7 +462,7 @@ type ObjectRef = IORef Object data Object =- Thunk (EgisonM WHNFData)+ Thunk (EvalM WHNFData) | WHNF WHNFData data WHNFData =@@ -506,7 +505,7 @@ -- class EgisonData a => EgisonWHNF a where toWHNF :: a -> WHNFData- fromWHNF :: WHNFData -> EgisonM a+ fromWHNF :: WHNFData -> EvalM a toWHNF = Value . toEgison instance EgisonWHNF Char where@@ -656,34 +655,39 @@ instance Exception EgisonError -liftError :: (MonadError e m) => Either e a -> m a-liftError = either throwError return- -- -- Monads -- -newtype EgisonM a = EgisonM {- unEgisonM :: ExceptT EgisonError (FreshT IO) a- } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh)--instance MonadFail EgisonM where- fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack+newtype EvalM a = EvalM {+ unEvalM :: StateT IState (ExceptT EgisonError IO) a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError) -runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a)-runEgisonM = runExceptT . unEgisonM+instance MonadFail EvalM where+ fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack -liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a-liftEgisonM m = EgisonM $ ExceptT $ FreshT $ do- s <- get- (a, s') <- return $ runFresh s m- put s'- return $ either throwError return a+instance MonadEval EvalM where+ fresh = EvalM $ do+ st <- get; modify (\st -> st { indexCounter = indexCounter st + 1 })+ return $ "$_" ++ show (indexCounter st)+ freshV = EvalM $ do+ st <- get; modify (\st -> st {indexCounter = indexCounter st + 1 })+ return $ Var ["$_" ++ show (indexCounter st)] []+ pushFuncName name = EvalM $ do+ st <- get+ put $ st { funcNameStack = name : funcNameStack st }+ return ()+ topFuncName = EvalM $ head . funcNameStack <$> get+ popFuncName = EvalM $ do+ st <- get+ put $ st { funcNameStack = tail $ funcNameStack st }+ return ()+ getFuncNameStack = EvalM $ funcNameStack <$> get -fromEgisonM :: EgisonM a -> IO (Either EgisonError a)-fromEgisonM = modifyCounter . runEgisonM+fromEvalM :: EvalM a -> IO (Either EgisonError a)+fromEvalM = runExceptT . modifyCounter . unEvalM -type MatchM = MaybeT EgisonM+type MatchM = MaybeT EvalM matchFail :: MatchM a matchFail = MaybeT $ return Nothing
hs-src/Language/Egison/Desugar.hs view
@@ -24,7 +24,7 @@ import Language.Egison.Data import Language.Egison.IState (fresh, freshV) -desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr+desugarTopExpr :: EgisonTopExpr -> EvalM EgisonTopExpr desugarTopExpr (Define name expr) = Define name <$> desugar expr desugarTopExpr (DefineWithIndices (VarWithIndices name is) expr) = do body <- desugar expr@@ -37,17 +37,17 @@ desugarTopExpr (Execute expr) = Execute <$> desugar expr desugarTopExpr expr = return expr -desugarExpr :: EgisonExpr -> EgisonM EgisonExpr+desugarExpr :: EgisonExpr -> EvalM EgisonExpr desugarExpr = desugar -desugar :: EgisonExpr -> EgisonM EgisonExpr+desugar :: EgisonExpr -> EvalM 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 -> EgisonM EgisonExpr+ genMatcherClauses :: [(String, [EgisonExpr])] -> EgisonExpr -> EvalM EgisonExpr genMatcherClauses patterns matcher = do main <- genMainClause patterns matcher body <- mapM genMatcherClause patterns@@ -55,7 +55,7 @@ let clauses = [main] ++ body ++ [footer] return $ MatcherExpr clauses - genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+ genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> EvalM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genMainClause patterns matcher = do clauses <- genClauses patterns return (PPValuePat "val", TupleExpr []@@ -64,34 +64,34 @@ (TupleExpr [matcher, matcher]) clauses)]) where- genClauses :: [(String, [EgisonExpr])] -> EgisonM [MatchClause]+ genClauses :: [(String, [EgisonExpr])] -> EvalM [MatchClause] genClauses patterns = (++) <$> mapM genClause patterns <*> pure [(TuplePat [WildCard, WildCard], matchingFailure)] - genClause :: (String, [EgisonExpr]) -> EgisonM MatchClause+ genClause :: (String, [EgisonExpr]) -> EvalM MatchClause genClause pattern = do (pat0, pat1) <- genMatchingPattern pattern return (TuplePat [pat0, pat1], matchingSuccess) - genMatchingPattern :: (String, [EgisonExpr]) -> EgisonM (EgisonPattern, EgisonPattern)+ genMatchingPattern :: (String, [EgisonExpr]) -> EvalM (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]) -> EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+ genMatcherClause :: (String, [EgisonExpr]) -> EvalM (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]) -> EgisonM (PrimitivePatPattern, [EgisonExpr])+ genPrimitivePatPat :: (String, [EgisonExpr]) -> EvalM (PrimitivePatPattern, [EgisonExpr]) genPrimitivePatPat (name, matchers) = do patterns' <- mapM (const $ return PPPatVar) matchers return (PPInductivePat name patterns', matchers) - genPrimitiveDataPat :: (String, [EgisonExpr]) -> EgisonM (PrimitiveDataPattern, [EgisonExpr])+ genPrimitiveDataPat :: (String, [EgisonExpr]) -> EvalM (PrimitiveDataPattern, [EgisonExpr]) genPrimitiveDataPat (name, patterns) = do patterns' <- mapM (const freshV) patterns return (PDInductivePat (capitalize name) $ map (PDPatVar . show) patterns', map VarExpr patterns')@@ -100,7 +100,7 @@ capitalize (x:xs) = toUpper x : xs - genSomethingClause :: EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+ genSomethingClause :: EvalM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genSomethingClause = return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (stringToVarExpr "tgt")])]) @@ -173,6 +173,9 @@ CollectionExpr inners' <- desugar (CollectionExpr inners) return $ CollectionExpr (SubCollectionExpr sub':inners') +desugar (HashExpr exprPairs) =+ HashExpr <$> mapM (\(expr1, expr2) -> (,) <$> desugar expr1 <*> desugar expr2) exprPairs+ desugar (VectorExpr exprs) = VectorExpr <$> mapM desugar exprs @@ -199,9 +202,6 @@ desugar (CambdaExpr name expr) = CambdaExpr name <$> desugar expr -desugar (ProcedureExpr names expr) =- ProcedureExpr names <$> desugar expr- desugar (PatternFunctionExpr names pattern) = PatternFunctionExpr names <$> desugarPattern pattern @@ -234,23 +234,23 @@ desugar (IoExpr expr) = IoExpr <$> desugar expr -desugar (UnaryOpExpr "-" expr) =- desugar (BinaryOpExpr mult (IntegerExpr (-1)) expr)+desugar (PrefixExpr "-" expr) =+ desugar (InfixExpr mult (IntegerExpr (-1)) expr) where mult = findOpFrom "*" reservedExprInfix-desugar (UnaryOpExpr "!" (ApplyExpr expr1 expr2)) =+desugar (PrefixExpr "!" (ApplyExpr expr1 expr2)) = WedgeApplyExpr <$> desugar expr1 <*> desugar expr2-desugar (UnaryOpExpr "'" expr) = QuoteExpr <$> desugar expr-desugar (UnaryOpExpr "`" expr) = QuoteSymbolExpr <$> desugar expr+desugar (PrefixExpr "'" expr) = QuoteExpr <$> desugar expr+desugar (PrefixExpr "`" expr) = QuoteSymbolExpr <$> desugar expr -desugar (BinaryOpExpr op expr1 expr2) | isWedge op =+desugar (InfixExpr op expr1 expr2) | isWedge op = (\x y -> WedgeApplyExpr (stringToVarExpr (func op)) (TupleExpr [x, y])) <$> desugar expr1 <*> desugar expr2 -desugar (BinaryOpExpr op expr1 expr2) | repr op == "::" =+desugar (InfixExpr op expr1 expr2) | repr op == "::" = (\x y -> CollectionExpr [ElementExpr x, SubCollectionExpr y]) <$> desugar expr1 <*> desugar expr2-desugar (BinaryOpExpr op expr1 expr2) | repr op == "++" =+desugar (InfixExpr op expr1 expr2) | repr op == "++" = (\x y -> CollectionExpr [SubCollectionExpr x, SubCollectionExpr y]) <$> desugar expr1 <*> desugar expr2-desugar (BinaryOpExpr op expr1 expr2) =+desugar (InfixExpr op expr1 expr2) = (\x y -> makeApply (func op) [x, y]) <$> desugar expr1 <*> desugar expr2 -- section@@ -262,17 +262,17 @@ x <- fresh y <- fresh desugar $ LambdaExpr [TensorArg x, TensorArg y]- (BinaryOpExpr op (stringToVarExpr x) (stringToVarExpr y))+ (InfixExpr op (stringToVarExpr x) (stringToVarExpr y)) desugar (SectionExpr op Nothing (Just expr2)) = do x <- fresh desugar $ LambdaExpr [TensorArg x]- (BinaryOpExpr op (stringToVarExpr x) expr2)+ (InfixExpr op (stringToVarExpr x) expr2) desugar (SectionExpr op (Just expr1) Nothing) = do y <- fresh desugar $ LambdaExpr [TensorArg y]- (BinaryOpExpr op expr1 (stringToVarExpr y))+ (InfixExpr op expr1 (stringToVarExpr y)) desugar SectionExpr{} = throwError $ Default "Cannot reach here: section with both arguments" @@ -313,11 +313,11 @@ desugar (MatcherExpr patternDefs) = MatcherExpr <$> mapM desugarPatternDef patternDefs -desugar (PartialVarExpr n) = return $ PartialVarExpr n+desugar (AnonParamExpr n) = return $ AnonParamExpr n -desugar (PartialExpr n expr) = do+desugar (AnonParamFuncExpr n expr) = do expr' <- desugar expr- return $ LetRecExpr [([stringToVar "::0"], PartialExpr n expr')] (stringToVarExpr "::0")+ return $ LetRecExpr [([stringToVar "::0"], AnonParamFuncExpr n expr')] (stringToVarExpr "::0") desugar (QuoteExpr expr) = QuoteExpr <$> desugar expr@@ -330,10 +330,10 @@ desugar expr = return expr -desugarIndex :: Index EgisonExpr -> EgisonM (Index EgisonExpr)+desugarIndex :: Index EgisonExpr -> EvalM (Index EgisonExpr) desugarIndex index = traverse desugar index -desugarPattern :: EgisonPattern -> EgisonM EgisonPattern+desugarPattern :: EgisonPattern -> EvalM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' (desugarPatternInfix pattern) where collectNames :: [EgisonPattern] -> Set String@@ -401,7 +401,7 @@ PowerPat (desugarPatternInfix pat1) (desugarPatternInfix pat2) desugarPatternInfix pat = pat -desugarPattern' :: EgisonPattern -> EgisonM EgisonPattern+desugarPattern' :: EgisonPattern -> EvalM EgisonPattern desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr desugarPattern' (PredPat expr) = PredPat <$> desugar expr desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern@@ -449,21 +449,21 @@ desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' pattern = return pattern -desugarLoopRange :: LoopRange -> EgisonM LoopRange+desugarLoopRange :: LoopRange -> EvalM LoopRange desugarLoopRange (LoopRange sExpr eExpr pattern) = LoopRange <$> desugar sExpr <*> desugar eExpr <*> desugarPattern' pattern -desugarBindings :: [BindingExpr] -> EgisonM [BindingExpr]+desugarBindings :: [BindingExpr] -> EvalM [BindingExpr] desugarBindings = mapM (\(name, expr) -> (name,) <$> desugar expr) -desugarMatchClauses :: [MatchClause] -> EgisonM [MatchClause]+desugarMatchClauses :: [MatchClause] -> EvalM [MatchClause] desugarMatchClauses = mapM (\(pattern, expr) -> (,) <$> desugarPattern pattern <*> desugar expr) -desugarPatternDef :: PatternDef -> EgisonM PatternDef+desugarPatternDef :: PatternDef -> EvalM PatternDef desugarPatternDef (pp, matcher, pds) = (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds -desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> EgisonM [(PrimitiveDataPattern, EgisonExpr)]+desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> EvalM [(PrimitiveDataPattern, EgisonExpr)] desugarPrimitiveDataMatchClauses = mapM (\(pd, expr) -> (pd,) <$> desugar expr) makeApply :: String -> [EgisonExpr] -> EgisonExpr
hs-src/Language/Egison/IState.hs view
@@ -12,16 +12,11 @@ module Language.Egison.IState ( IState(..)- , FreshT(..)- , Fresh- , MonadFresh(..)- , runFreshT- , runFresh+ , MonadEval(..) , modifyCounter ) where import Control.Monad.Except-import Control.Monad.Identity import Control.Monad.State import Data.IORef @@ -37,12 +32,7 @@ , funcNameStack :: [String] } -newtype FreshT m a = FreshT { unFreshT :: StateT IState m a }- deriving (Functor, Applicative, Monad, MonadState IState, MonadTrans)--type Fresh = FreshT Identity--class (Applicative m, Monad m) => MonadFresh m where+class (Applicative m, Monad m) => MonadEval m where fresh :: m String freshV :: m Var pushFuncName :: String -> m ()@@ -50,37 +40,7 @@ popFuncName :: m () getFuncNameStack :: m [String] -instance (Applicative m, Monad m) => MonadFresh (FreshT m) where- fresh = FreshT $ do- st <- get; modify (\st -> st { indexCounter = indexCounter st + 1 })- return $ "$_" ++ show (indexCounter st)- freshV = FreshT $ do- st <- get; modify (\st -> st {indexCounter = indexCounter st + 1 })- return $ Var ["$_" ++ show (indexCounter st)] []- pushFuncName name = FreshT $ do- st <- get- put $ st { funcNameStack = name : funcNameStack st }- return ()- topFuncName = FreshT $ head . funcNameStack <$> get- popFuncName = FreshT $ do- st <- get- put $ st { funcNameStack = tail $ funcNameStack st }- return ()- getFuncNameStack = FreshT $ funcNameStack <$> get--instance (MonadState s m) => MonadState s (FreshT m) where- get = lift get- put s = lift $ put s--instance (MonadFresh m) => MonadFresh (StateT s m) where- fresh = lift fresh- freshV = lift freshV- pushFuncName name = lift $ pushFuncName name- topFuncName = lift topFuncName- popFuncName = lift popFuncName- getFuncNameStack = lift getFuncNameStack--instance (MonadFresh m) => MonadFresh (ExceptT e m) where+instance (MonadEval m) => MonadEval (ExceptT e m) where fresh = lift fresh freshV = lift freshV pushFuncName name = lift $ pushFuncName name@@ -88,15 +48,6 @@ popFuncName = lift popFuncName getFuncNameStack = lift getFuncNameStack -instance MonadIO (FreshT IO) where- liftIO = lift--runFreshT :: Monad m => IState -> FreshT m a -> m (a, IState)-runFreshT = flip (runStateT . unFreshT)--runFresh :: IState -> Fresh a -> (a, IState)-runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m- {-# NOINLINE counter #-} counter :: IORef Int counter = unsafePerformIO $ newIORef 0@@ -107,9 +58,9 @@ updateCounter :: Int -> IO () updateCounter = writeIORef counter -modifyCounter :: FreshT IO a -> IO a+modifyCounter :: MonadIO m => StateT IState m a -> m a modifyCounter m = do- x <- readCounter- (result, st) <- runFreshT (IState { indexCounter = x, funcNameStack = [] }) m- updateCounter $ indexCounter st+ x <- liftIO $ readCounter+ (result, st) <- runStateT m (IState { indexCounter = x, funcNameStack = [] })+ liftIO $ updateCounter $ indexCounter st return result
hs-src/Language/Egison/MathExpr.hs view
@@ -15,6 +15,9 @@ , PolyExpr (..) , TermExpr (..) , SymbolExpr (..)+ , Printable (..)+ , pattern ZeroExpr+ , pattern SingleSymbol , pattern SingleTerm -- * Scalar , mathNormalize'@@ -63,6 +66,12 @@ type Id = String +pattern ZeroExpr :: ScalarData+pattern ZeroExpr = (Div (Plus []) (Plus [Term 1 []]))++pattern SingleSymbol :: SymbolExpr -> ScalarData+pattern SingleSymbol sym = Div (Plus [Term 1 [(sym, 1)]]) (Plus [Term 1 []])+ -- Product of a coefficient and a monomial pattern SingleTerm :: Integer -> Monomial -> ScalarData pattern SingleTerm coeff mono = Div (Plus [Term coeff mono]) (Plus [Term 1 []])@@ -97,67 +106,81 @@ Nothing -> False _ == _ = False -class Complex a where+class Printable a where isAtom :: a -> Bool+ pretty :: a -> String -show' :: (Complex a, Show a) => a -> String-show' e | isAtom e = show e-show' e = "(" ++ show e ++ ")"+pretty' :: Printable a => a -> String+pretty' e | isAtom e = pretty e+pretty' e = "(" ++ pretty e ++ ")" -instance Complex ScalarData where+instance Printable ScalarData where isAtom (Div p (Plus [Term 1 []])) = isAtom p isAtom _ = False -instance Complex PolyExpr where+ pretty (Div p1 (Plus [Term 1 []])) = pretty p1+ pretty (Div p1 p2) = pretty'' p1 ++ " / " ++ pretty' p2+ where+ pretty'' :: PolyExpr -> String+ pretty'' p@(Plus [_]) = pretty p+ pretty'' p = "(" ++ pretty p ++ ")"++instance Printable PolyExpr where isAtom (Plus []) = True isAtom (Plus [Term _ []]) = True isAtom (Plus [Term 1 [_]]) = True isAtom _ = False -instance Complex SymbolExpr where+ pretty (Plus []) = "0"+ pretty (Plus (t:ts)) = pretty t ++ concatMap withSign ts+ where+ withSign (Term a xs) | a < 0 = " - " ++ pretty (Term (- a) xs)+ withSign t = " + " ++ pretty t++instance Printable SymbolExpr where isAtom Symbol{} = True isAtom (Apply _ []) = True isAtom _ = False + pretty (Symbol _ (':':':':':':_) []) = "#"+ pretty (Symbol _ s []) = s+ pretty (Symbol _ s js) = s ++ concatMap show js+ pretty (Apply fn mExprs) = unwords (map pretty' (fn : mExprs))+ pretty (Quote mExprs) = "'" ++ pretty' mExprs+ pretty (FunctionData name _ _ js) = pretty name ++ concatMap show js++instance Printable TermExpr where+ isAtom (Term _ []) = True+ isAtom (Term 1 [_]) = True+ isAtom _ = False++ pretty (Term a []) = show a+ pretty (Term 1 xs) = intercalate " * " (map prettyPoweredSymbol xs)+ pretty (Term (-1) xs) = "- " ++ intercalate " * " (map prettyPoweredSymbol xs)+ pretty (Term a xs) = intercalate " * " (show a : map prettyPoweredSymbol xs)++prettyPoweredSymbol :: (SymbolExpr, Integer) -> String+prettyPoweredSymbol (x, 1) = show x+prettyPoweredSymbol (x, n) = pretty' x ++ "^" ++ show n+ instance Show ScalarData where- show (Div p1 (Plus [Term 1 []])) = show p1- show (Div p1 p2) = show'' p1 ++ " / " ++ show' p2- where- show'' :: PolyExpr -> String- show'' p@(Plus [_]) = show p- show'' p = "(" ++ show p ++ ")"+ show = pretty instance Show PolyExpr where- show (Plus []) = "0"- show (Plus (t:ts)) = show t ++ concatMap showWithSign ts- where- showWithSign (Term a xs) | a < 0 = " - " ++ show (Term (- a) xs)- showWithSign t = " + " ++ show t+ show = pretty instance Show TermExpr where- show (Term a []) = show a- show (Term 1 xs) = intercalate " * " (map showPoweredSymbol xs)- show (Term (-1) xs) = "- " ++ intercalate " * " (map showPoweredSymbol xs)- show (Term a xs) = intercalate " * " (show a : map showPoweredSymbol xs)--showPoweredSymbol :: (SymbolExpr, Integer) -> String-showPoweredSymbol (x, 1) = show x-showPoweredSymbol (x, n) = show' x ++ "^" ++ show n+ show = pretty instance Show SymbolExpr where- show (Symbol _ (':':':':':':_) []) = "#"- show (Symbol _ s []) = s- show (Symbol _ s js) = s ++ concatMap show js- show (Apply fn mExprs) = unwords (map show' (fn : mExprs))- show (Quote mExprs) = "'" ++ show' mExprs- show (FunctionData name _ _ js) = show name ++ concatMap show js+ show = pretty instance Show (Index ScalarData) where- show (Superscript i) = "~" ++ show i- show (Subscript i) = "_" ++ show i- show (SupSubscript i) = "~_" ++ show i+ show (Superscript i) = "~" ++ pretty' i+ show (Subscript i) = "_" ++ pretty' i+ show (SupSubscript i) = "~_" ++ pretty' i show (DFscript _ _) = ""- show (Userscript i) = "|" ++ show i+ show (Userscript i) = "|" ++ pretty' i -- -- Scalars
hs-src/Language/Egison/MathOutput.hs view
@@ -10,9 +10,13 @@ ( changeOutputInLang ) where -import Data.List (intercalate)+import Text.ParserCombinators.Parsec (parse) -import Text.ParserCombinators.Parsec hiding (spaces)+import Language.Egison.PrettyMath.AST+import qualified Language.Egison.PrettyMath.AsciiMath as AsciiMath+import qualified Language.Egison.PrettyMath.Latex as Latex+import qualified Language.Egison.PrettyMath.Mathematica as Mathematica+import qualified Language.Egison.PrettyMath.Maxima as Maxima changeOutputInLang :: String -> String -> String changeOutputInLang lang input =@@ -25,336 +29,9 @@ output -> "#" ++ lang ++ "|" ++ output ++ "|#" showMathExpr :: String -> MathExpr -> String-showMathExpr "asciimath" = showMathExprAsciiMath-showMathExpr "latex" = showMathExprLatex-showMathExpr "mathematica" = showMathExprMathematica-showMathExpr "maxima" = showMathExprMaxima+showMathExpr "asciimath" = AsciiMath.showMathExpr+showMathExpr "latex" = Latex.showMathExpr+showMathExpr "mathematica" = Mathematica.showMathExpr+showMathExpr "maxima" = Maxima.showMathExpr showMathExpr "haskell" = show showMathExpr _ = error "Unreachable"--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)--isSub :: MathIndex -> Bool-isSub (Sub _) = True-isSub _ = False------- Show (AsciiMath)-----showMathExprAsciiMath :: MathExpr -> String-showMathExprAsciiMath (Atom func []) = func-showMathExprAsciiMath (NegativeAtom func) = "-" ++ func-showMathExprAsciiMath (Plus []) = ""-showMathExprAsciiMath (Plus (x:xs)) = showMathExprAsciiMath x ++ showMathExprAsciiMathForPlus xs- where- showMathExprAsciiMathForPlus :: [MathExpr] -> String- showMathExprAsciiMathForPlus [] = ""- showMathExprAsciiMathForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprAsciiMathForPlus xs- showMathExprAsciiMathForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprAsciiMath (Multiply ys) ++ showMathExprAsciiMathForPlus xs- showMathExprAsciiMathForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprAsciiMath (Multiply (Atom a []:ys)) ++ " " ++ showMathExprAsciiMathForPlus xs- showMathExprAsciiMathForPlus (x:xs) = " + " ++ showMathExprAsciiMath x ++ showMathExprAsciiMathForPlus xs-showMathExprAsciiMath (Multiply []) = ""-showMathExprAsciiMath (Multiply [a]) = showMathExprAsciiMath a-showMathExprAsciiMath (Multiply (NegativeAtom "1":lvs)) = "-" ++ showMathExprAsciiMath (Multiply lvs)-showMathExprAsciiMath (Multiply lvs) = showMathExprAsciiMath' (head lvs) ++ " " ++ showMathExprAsciiMath (Multiply (tail lvs))-showMathExprAsciiMath (Power lv1 lv2) = showMathExprAsciiMath lv1 ++ "^" ++ showMathExprAsciiMath lv2-showMathExprAsciiMath (Func (Atom "sqrt" []) [x]) = "sqrt " ++ showMathExprAsciiMath x-showMathExprAsciiMath (Func (Atom "rt" []) [x, y]) = "root " ++ showMathExprAsciiMath x ++ " " ++ showMathExprAsciiMath y-showMathExprAsciiMath (Func (Atom "/" []) [x, y]) = "frac{" ++ showMathExprAsciiMath x ++ "}{" ++ showMathExprAsciiMath y ++ "}"-showMathExprAsciiMath (Func f lvs) = showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")"-showMathExprAsciiMath (Tensor lvs mis)- | null mis = "(" ++ showMathExprAsciiMathArg lvs ++ ")"- | not (any isSub mis) = "(" ++ showMathExprAsciiMathArg lvs ++ ")^(" ++ showMathExprAsciiMathIndices mis ++ ")"- | not (any (not . isSub) mis) = "(" ++ showMathExprAsciiMathArg lvs ++ ")_(" ++ showMathExprAsciiMathIndices mis ++ ")"- | otherwise = "(" ++ showMathExprAsciiMathArg lvs ++ ")_(" ++ showMathExprAsciiMathIndices (filter isSub mis) ++ ")^(" ++ showMathExprAsciiMathIndices (filter (not . isSub) mis) ++ ")"-showMathExprAsciiMath (Tuple lvs) = "(" ++ showMathExprAsciiMathArg lvs ++ ")"-showMathExprAsciiMath (Collection lvs) = "{" ++ showMathExprAsciiMathArg lvs ++ "}"-showMathExprAsciiMath (Exp x) = "e^(" ++ showMathExprAsciiMath x ++ ")"--showMathExprAsciiMath' :: MathExpr -> String-showMathExprAsciiMath' (Plus lvs) = "(" ++ showMathExprAsciiMath (Plus lvs) ++ ")"-showMathExprAsciiMath' val = showMathExprAsciiMath val--showMathExprAsciiMathArg :: [MathExpr] -> String-showMathExprAsciiMathArg exprs = intercalate ", " $ map showMathExprAsciiMath exprs--showMathExprAsciiMathIndices :: [MathIndex] -> String-showMathExprAsciiMathIndices [] = error "unreachable"-showMathExprAsciiMathIndices lvs = concatMap showMathIndexAsciiMath lvs--showMathIndexAsciiMath :: MathIndex -> String-showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a-showMathIndexAsciiMath (Sub a) = showMathExprAsciiMath a------- Show (Latex)-----showMathExprLatex :: MathExpr -> String-showMathExprLatex (Atom a []) = a-showMathExprLatex (Atom a xs) = a ++ showMathExprLatexScript xs-showMathExprLatex (Partial f xs) = "\\frac{" ++ convertToPartial (f, length xs) ++ "}{" ++ showPartial xs ++ "}"- where- showPartial :: [MathExpr] -> String- showPartial xs = let lx = elemCount xs in convertToPartial2 (head lx) ++ foldr (\x acc -> " " ++ convertToPartial2 x ++ acc) "" (tail lx)-- convertToPartial :: (MathExpr, Int) -> String- convertToPartial (x, 1) = "\\partial " ++ showMathExprLatex x- convertToPartial (x, n) = "\\partial^" ++ show n ++ " " ++ showMathExprLatex x-- convertToPartial2 :: (MathExpr, Int) -> String- convertToPartial2 (x, 1) = "\\partial " ++ showMathExprLatex x- convertToPartial2 (x, n) = "\\partial " ++ showMathExprLatex x ++ "^" ++ show n-showMathExprLatex (NegativeAtom a) = "-" ++ a-showMathExprLatex (Plus []) = ""-showMathExprLatex (Plus (x:xs)) = showMathExprLatex x ++ showMathExprLatexForPlus xs- where- showMathExprLatexForPlus :: [MathExpr] -> String- showMathExprLatexForPlus [] = ""- showMathExprLatexForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprLatexForPlus xs- showMathExprLatexForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprLatex (Multiply ys) ++ showMathExprLatexForPlus xs- showMathExprLatexForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprLatex (Multiply (Atom a []:ys)) ++ showMathExprLatexForPlus xs- showMathExprLatexForPlus (x:xs) = " + " ++ showMathExprLatex x ++ showMathExprLatexForPlus xs-showMathExprLatex (Multiply []) = ""-showMathExprLatex (Multiply [x]) = showMathExprLatex x-showMathExprLatex (Multiply (Atom "1" []:xs)) = showMathExprLatex (Multiply xs)-showMathExprLatex (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExprLatex (Multiply xs)-showMathExprLatex (Multiply (x:xs)) = showMathExprLatex' x ++ " " ++ showMathExprLatex (Multiply xs)-showMathExprLatex (Power lv1 lv2) = showMathExprLatex lv1 ++ "^" ++ showMathExprLatex lv2-showMathExprLatex (Func (Atom "sqrt" []) [x]) = "\\sqrt{" ++ showMathExprLatex x ++ "}"-showMathExprLatex (Func (Atom "rt" []) [x, y]) = "\\sqrt[" ++ showMathExprLatex x ++ "]{" ++ showMathExprLatex y ++ "}"-showMathExprLatex (Func (Atom "/" []) [x, y]) = "\\frac{" ++ showMathExprLatex x ++ "}{" ++ showMathExprLatex y ++ "}"-showMathExprLatex (Func f xs) = showMathExprLatex f ++ "(" ++ showMathExprLatexArg xs ", " ++ ")"-showMathExprLatex (Tensor xs mis) = "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis-showMathExprLatex (Tuple xs) = "(" ++ showMathExprLatexArg xs ", " ++ ")"-showMathExprLatex (Collection xs) = "\\{" ++ showMathExprLatexArg xs ", " ++ "\\}"-showMathExprLatex (Exp x) = "e^{" ++ showMathExprLatex x ++ "}"-showMathExprLatex (Quote x) = "(" ++ showMathExprLatex x ++ ")"--showMathExprLatex' :: MathExpr -> String-showMathExprLatex' (Plus xs) = "(" ++ showMathExprLatex (Plus xs) ++ ")"-showMathExprLatex' x = showMathExprLatex x--showMathExprLatexArg :: [MathExpr] -> String -> String-showMathExprLatexArg exprs sep = intercalate sep $ map showMathExprLatex exprs--showMathExprLatexSuper :: MathIndex -> String-showMathExprLatexSuper (Super (Atom "#" [])) = "\\#"-showMathExprLatexSuper (Super x) = showMathExprLatex x-showMathExprLatexSuper (Sub _) = "\\;"--showMathExprLatexSub :: MathIndex -> String-showMathExprLatexSub (Sub (Atom "#" [])) = "\\#"-showMathExprLatexSub (Sub x) = showMathExprLatex x-showMathExprLatexSub (Super _) = "\\;"--showMathExprLatexScript :: [MathIndex] -> String-showMathExprLatexScript [] = ""-showMathExprLatexScript is = "_{" ++ concatMap showMathExprLatexSub is ++ "}^{" ++ concatMap showMathExprLatexSuper is ++ "}"--showMathExprLatexVectors :: [MathExpr] -> String-showMathExprLatexVectors [] = ""-showMathExprLatexVectors (Tensor lvs []:r) = showMathExprLatexArg lvs " & " ++ " \\\\ " ++ showMathExprLatexVectors r-showMathExprLatexVectors lvs = showMathExprLatexArg lvs " \\\\ " ++ "\\\\ "------- Show (Mathematica)-----showMathExprMathematica :: MathExpr -> String-showMathExprMathematica (Atom a []) = a-showMathExprMathematica (Partial f xs) = showMathExprMathematica f ++ "_" ++ showMathExprsMathematica "_" xs-showMathExprMathematica (NegativeAtom a) = "-" ++ a-showMathExprMathematica (Plus []) = ""-showMathExprMathematica (Plus (x:xs)) = showMathExprMathematica x ++ showMathExprMathematicaForPlus xs- where- showMathExprMathematicaForPlus :: [MathExpr] -> String- showMathExprMathematicaForPlus [] = ""- showMathExprMathematicaForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprMathematicaForPlus xs- showMathExprMathematicaForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprMathematica (Multiply ys) ++ showMathExprMathematicaForPlus xs- showMathExprMathematicaForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprMathematica (Multiply (Atom a []:ys)) ++ showMathExprMathematicaForPlus xs- showMathExprMathematicaForPlus (x:xs) = " + " ++ showMathExprMathematica x ++ showMathExprMathematicaForPlus xs-showMathExprMathematica (Multiply []) = ""-showMathExprMathematica (Multiply [x]) = showMathExprMathematica x-showMathExprMathematica (Multiply (Atom "1" []:xs)) = showMathExprMathematica (Multiply xs)-showMathExprMathematica (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExprMathematica (Multiply xs)-showMathExprMathematica (Multiply (x:xs)) = showMathExprMathematica' x ++ " " ++ showMathExprMathematica (Multiply xs)-showMathExprMathematica (Power lv1 lv2) = showMathExprMathematica lv1 ++ "^" ++ showMathExprMathematica lv2-showMathExprMathematica (Func (Atom "sqrt" []) [x]) = "Sqrt[" ++ showMathExprMathematica x ++ "]"-showMathExprMathematica (Func (Atom "rt" []) [x, y]) = "Surd[" ++ showMathExprMathematica x ++ "," ++ showMathExprMathematica y ++ "]"-showMathExprMathematica (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y- where- addBracket x@(Atom _ []) = showMathExprMathematica x- addBracket x = "(" ++ showMathExprMathematica x ++ ")"-showMathExprMathematica (Func f xs) = showMathExprMathematica f ++ "(" ++ showMathExprMathematicaArg xs ++ ")"-showMathExprMathematica (Tensor lvs mis)- | null mis = "{" ++ showMathExprMathematicaArg lvs ++ "}"- | not (any isSub mis) = "{" ++ showMathExprMathematicaArg lvs ++ "}^(" ++ showMathExprMathematicaIndices mis ++ ")"- | not (any (not . isSub) mis) = "{" ++ showMathExprMathematicaArg lvs ++ "}_(" ++ showMathExprMathematicaIndices mis ++ ")"- | otherwise = "{" ++ showMathExprMathematicaArg lvs ++ "}_(" ++ showMathExprMathematicaIndices (filter isSub mis) ++ ")^(" ++ showMathExprMathematicaIndices (filter (not . isSub) mis) ++ ")"-showMathExprMathematica (Tuple xs) = "(" ++ showMathExprMathematicaArg xs ++ ")"-showMathExprMathematica (Collection xs) = "{" ++ showMathExprMathematicaArg xs ++ "}"-showMathExprMathematica (Exp x) = "e^(" ++ showMathExprMathematica x ++ ")"-showMathExprMathematica (Quote x) = "(" ++ showMathExprMathematica x ++ ")"--showMathExprMathematica' :: MathExpr -> String-showMathExprMathematica' (Plus xs) = "(" ++ showMathExprMathematica (Plus xs) ++ ")"-showMathExprMathematica' x = showMathExprMathematica x--showMathExprsMathematica :: String -> [MathExpr] -> String-showMathExprsMathematica sep exprs = intercalate sep $ map showMathExprMathematica exprs--showMathExprMathematicaArg :: [MathExpr] -> String-showMathExprMathematicaArg = showMathExprsMathematica ", "--showMathExprMathematicaIndices :: [MathIndex] -> String-showMathExprMathematicaIndices [] = error "unreachable"-showMathExprMathematicaIndices lvs = concatMap showMathIndexMathematica lvs--showMathIndexMathematica :: MathIndex -> String-showMathIndexMathematica (Super a) = showMathExprMathematica a-showMathIndexMathematica (Sub a) = showMathExprMathematica a------- Show (Maxima)-----showMathExprMaxima :: MathExpr -> String-showMathExprMaxima (Atom a []) = a-showMathExprMaxima (Partial _ _) = "undefined"-showMathExprMaxima (NegativeAtom a) = "-" ++ a-showMathExprMaxima (Plus []) = ""-showMathExprMaxima (Plus (x:xs)) = showMathExprMaxima x ++ showMathExprMaximaForPlus xs- where- showMathExprMaximaForPlus :: [MathExpr] -> String- showMathExprMaximaForPlus [] = ""- showMathExprMaximaForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprMaximaForPlus xs- showMathExprMaximaForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprMaxima (Multiply ys) ++ showMathExprMaximaForPlus xs- showMathExprMaximaForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprMaxima (Multiply (Atom a []:ys)) ++ showMathExprMaximaForPlus xs- showMathExprMaximaForPlus (x:xs) = " + " ++ showMathExprMaxima x ++ showMathExprMaximaForPlus xs-showMathExprMaxima (Multiply []) = ""-showMathExprMaxima (Multiply [x]) = showMathExprMaxima x-showMathExprMaxima (Multiply (Atom "1" []:xs)) = showMathExprMaxima (Multiply xs)-showMathExprMaxima (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExprMaxima (Multiply xs)-showMathExprMaxima (Multiply (x:xs)) = showMathExprMaxima' x ++ " * " ++ showMathExprMaxima (Multiply xs)-showMathExprMaxima (Power lv1 lv2) = showMathExprMaxima lv1 ++ "^" ++ showMathExprMaxima lv2-showMathExprMaxima (Func (Atom "sqrt" []) [x]) = "sqrt(" ++ showMathExprMaxima x ++ ")"-showMathExprMaxima (Func (Atom "rt" []) [x, y]) = showMathExprMaxima y ++ "^(1/" ++ showMathExprMaxima x ++ ")"-showMathExprMaxima (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y- where- addBracket x@(Atom _ []) = showMathExprMaxima x- addBracket x = "(" ++ showMathExprMaxima x ++ ")"-showMathExprMaxima (Func f xs) = showMathExprMaxima f ++ "(" ++ showMathExprMaximaArg xs ++ ")"-showMathExprMaxima (Tensor _ _) = "undefined"-showMathExprMaxima (Tuple _) = "undefined"-showMathExprMaxima (Collection xs) = "[" ++ showMathExprMaximaArg xs ++ "]"-showMathExprMaxima (Exp x) = "exp(" ++ showMathExprMaxima x ++ ")"-showMathExprMaxima (Quote x) = "(" ++ showMathExprMaxima x ++ ")"--showMathExprMaxima' :: MathExpr -> String-showMathExprMaxima' x@(Plus _) = "(" ++ showMathExprMaxima x ++ ")"-showMathExprMaxima' x = showMathExprMaxima x--showMathExprMaximaArg :: [MathExpr] -> String-showMathExprMaximaArg [] = ""-showMathExprMaximaArg [Tensor _ []] = "undefined"-showMathExprMaximaArg [a] = showMathExprMaxima a-showMathExprMaximaArg lvs = showMathExprMaxima (head lvs) ++ ", " ++ showMathExprMaximaArg (tail lvs)-------- Parser-----spaces :: Parser ()-spaces = skipMany1 space--spaces0 :: Parser ()-spaces0 = skipMany space--symbol :: Parser Char-symbol = oneOf "!$%&*+-/:<=>?@#"--parseAtom :: Parser MathExpr-parseAtom = Atom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol)) <*> many parseScript--parseAtom' :: Parser MathExpr-parseAtom' = flip Atom [] <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol))--parsePartial :: Parser MathExpr-parsePartial = Partial <$> parseAtom <*> many1 (char '|' >> parseAtom)--parseNegativeAtom :: Parser MathExpr-parseNegativeAtom = char '-' >> NegativeAtom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol))--parseList :: Parser [MathExpr]-parseList = sepEndBy parseExpr spaces--parseScript :: Parser MathIndex-parseScript = Sub <$> (char '_' >> parseAtom')- <|> Super <$> (char '~' >> parseAtom')--parsePlus :: Parser MathExpr-parsePlus = string "(+" >> spaces >> Plus <$> parseList <* char ')'--parseMultiply :: Parser MathExpr-parseMultiply = string "(*" >> spaces >> Multiply <$> parseList <* char ')'--parseFunction :: Parser MathExpr-parseFunction = char '(' >> Func <$> parseAtom <* spaces <*> parseList <* char ')'--parseTensor :: Parser MathExpr-parseTensor = string "[|" >> spaces0 >> Tensor <$> parseList <* spaces0 <* string "|]" <*> many parseScript--parseTuple :: Parser MathExpr-parseTuple = char '[' >> Tuple <$> parseList <* char ']'--parseCollection :: Parser MathExpr-parseCollection = char '{' >> Collection <$> parseList <* char '}'--parseExp :: Parser MathExpr-parseExp = string "(exp" >> spaces >> Exp <$> parseExpr <* char ')'--parseQuote :: Parser MathExpr-parseQuote = char '\'' >> Quote <$> parseExpr'--parseExpr' :: Parser MathExpr-parseExpr' = parseNegativeAtom- <|> try parsePartial- <|> parseAtom- <|> parseQuote- <|> try parseExp- <|> try parsePlus- <|> try parseMultiply- <|> try parseFunction- <|> try parseTensor- <|> try parseTuple- <|> try parseCollection--parseExpr :: Parser MathExpr-parseExpr = do- x <- parseExpr'- option x $ Power x <$> try (char '^' >> parseExpr')--elemCount :: Eq a => [a] -> [(a, Int)]-elemCount [] = []-elemCount (x:xs) = (x, length (filter (== x) xs) + 1) : elemCount (filter (/= x) xs)
hs-src/Language/Egison/Parser.hs view
@@ -15,6 +15,9 @@ -- * Parse and desugar a file , loadLibraryFile , loadFile+ -- * Parser utils (for translator)+ , removeShebang+ , readUTF8File ) where import Control.Monad.Except (liftIO, throwError)@@ -30,33 +33,33 @@ import qualified Language.Egison.Parser.NonS as NonS import Paths_egison (getDataFileName) -readTopExprs :: Bool -> String -> EgisonM [EgisonTopExpr]+readTopExprs :: Bool -> String -> EvalM [EgisonTopExpr] readTopExprs useSExpr = either throwError (mapM desugarTopExpr) . parseTopExprs where parseTopExprs | useSExpr = SExpr.parseTopExprs | otherwise = NonS.parseTopExprs -- TODO(momohatt): Parse from the last state-readTopExpr :: Bool -> String -> EgisonM EgisonTopExpr+readTopExpr :: Bool -> String -> EvalM EgisonTopExpr readTopExpr useSExpr = either throwError desugarTopExpr . parseTopExpr where parseTopExpr | useSExpr = SExpr.parseTopExpr | otherwise = NonS.parseTopExpr -readExprs :: Bool -> String -> EgisonM [EgisonExpr]+readExprs :: Bool -> String -> EvalM [EgisonExpr] readExprs useSExpr = either throwError (mapM desugarExpr) . parseExprs where parseExprs | useSExpr = SExpr.parseExprs | otherwise = NonS.parseExprs -readExpr :: Bool -> String -> EgisonM EgisonExpr+readExpr :: Bool -> String -> EvalM EgisonExpr readExpr useSExpr = either throwError desugarExpr . parseExpr where parseExpr | useSExpr = SExpr.parseExpr | otherwise = NonS.parseExpr -- |Load a libary file-loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]+loadLibraryFile :: FilePath -> EvalM [EgisonTopExpr] loadLibraryFile file = do homeDir <- liftIO getHomeDirectory doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file@@ -65,22 +68,23 @@ else liftIO (getDataFileName file) >>= loadFile -- |Load a file-loadFile :: FilePath -> EgisonM [EgisonTopExpr]+loadFile :: FilePath -> EvalM [EgisonTopExpr] loadFile file = do doesExist <- liftIO $ doesFileExist file unless doesExist $ throwError $ Default ("file does not exist: " ++ file) input <- liftIO $ readUTF8File file useSExpr <- checkIfUseSExpr file- exprs <- readTopExprs useSExpr $ shebang input+ exprs <- readTopExprs useSExpr $ removeShebang useSExpr 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 +removeShebang :: Bool -> String -> String+removeShebang useSExpr cs@('#':'!':_) = if useSExpr then ';' : cs else "--" ++ cs+removeShebang _ cs = cs+ readUTF8File :: FilePath -> IO String readUTF8File name = do h <- openFile name ReadMode@@ -93,7 +97,7 @@ hasDotSEgiExtension :: String -> Bool hasDotSEgiExtension file = drop (length file - 5) file == ".segi" -checkIfUseSExpr :: String -> EgisonM Bool+checkIfUseSExpr :: String -> EvalM Bool checkIfUseSExpr file | hasDotEgiExtension file = return False | hasDotSEgiExtension file = return True
hs-src/Language/Egison/Parser/NonS.hs view
@@ -67,6 +67,7 @@ data CustomError = IllFormedSection Infix Infix | IllFormedDefine+ | LastStmtInDoBlock deriving (Eq, Ord) instance ShowErrorComponent CustomError where@@ -77,6 +78,8 @@ "'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]" showErrorComponent IllFormedDefine = "Failed to parse the left hand side of definition expression."+ showErrorComponent LastStmtInDoBlock =+ "The last statement in a 'do' block must be an expression." doParse :: Parser a -> String -> Either EgisonError a@@ -163,13 +166,16 @@ convertToDefine (VarExpr var) = return $ Variable var convertToDefine (SectionExpr op Nothing Nothing) = return $ Variable (stringToVar (func op))+ convertToDefine (ApplyExpr (VarExpr var) (TupleExpr [TupleExpr args])) = do+ args' <- mapM ((TensorArg <$>) . exprToStr) args+ return $ Function var args' convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) = do args' <- mapM ((TensorArg <$>) . exprToStr) args return $ Function var args' convertToDefine (ApplyExpr (SectionExpr op Nothing Nothing) (TupleExpr [x, y])) = do args <- mapM ((TensorArg <$>) . exprToStr) [x, y] return $ Function (stringToVar (repr op)) args- convertToDefine e@(BinaryOpExpr op _ _)+ convertToDefine e@(InfixExpr op _ _) | repr op == "*" || repr op == "%" || repr op == "$" = do args <- exprToArgs e case args of@@ -190,19 +196,19 @@ exprToArgs (ApplyExpr func (TupleExpr args)) = (++) <$> exprToArgs func <*> mapM ((TensorArg <$>) . exprToStr) args exprToArgs (SectionExpr op Nothing Nothing) = return [TensorArg (func op)]- exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "*" = do+ exprToArgs (InfixExpr op lhs rhs) | repr op == "*" = do lhs' <- exprToArgs lhs rhs' <- exprToArgs rhs case rhs' of TensorArg x : xs -> return (lhs' ++ InvertedScalarArg x : xs) _ -> Nothing- exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "$" = do+ exprToArgs (InfixExpr op lhs rhs) | repr op == "$" = do lhs' <- exprToArgs lhs rhs' <- exprToArgs rhs case rhs' of TensorArg x : xs -> return (lhs' ++ ScalarArg x : xs) _ -> Nothing- exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "%" = do+ exprToArgs (InfixExpr op lhs rhs) | repr op == "%" = do lhs' <- exprToArgs lhs rhs' <- exprToArgs rhs case rhs' of@@ -256,14 +262,14 @@ where -- notFollowedBy (in unary and binary) is necessary for section expression. unary :: String -> Parser (EgisonExpr -> EgisonExpr)- unary sym = UnaryOpExpr <$> try (operator sym <* notFollowedBy (symbol ")"))+ unary sym = PrefixExpr <$> try (operator sym <* notFollowedBy (symbol ")")) binary :: Infix -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr) binary op = do -- Operators should be indented than pos1 in order to avoid -- "1\n-2" (2 topExprs, 1 and -2) to be parsed as "1 - 2". op <- try (indented >> infixLiteral (repr op) <* notFollowedBy (symbol ")"))- return $ BinaryOpExpr op+ return $ InfixExpr op toOperator :: Infix -> Operator Parser EgisonExpr toOperator = infixToOperator binary@@ -311,7 +317,6 @@ lambdaLikeExpr :: Parser EgisonExpr lambdaLikeExpr = (reserved "memoizedLambda" >> MemoizedLambdaExpr <$> tupleOrSome lowerId <*> (symbol "->" >> expr))- <|> (reserved "procedure" >> ProcedureExpr <$> tupleOrSome lowerId <*> (symbol "->" >> expr)) <|> (reserved "cambda" >> CambdaExpr <$> lowerId <*> (symbol "->" >> expr)) arg :: Parser Arg@@ -347,10 +352,10 @@ doExpr :: Parser EgisonExpr doExpr = do stmts <- reserved "do" >> oneLiner <|> alignSome statement- return $ case last stmts of- ([], retExpr@(ApplyExpr (VarExpr (Var ["return"] _)) _)) ->- DoExpr (init stmts) retExpr- _ -> DoExpr stmts (makeApply' "return" [])+ case reverse stmts of+ [] -> return $ DoExpr [] (makeApply' "return" [])+ ([], expr):_ -> return $ DoExpr (init stmts) expr+ _:_ -> customFailure LastStmtInDoBlock where statement :: Parser BindingExpr statement = (reserved "let" >> binding) <|> ([],) <$> expr@@ -447,7 +452,7 @@ op <- choice $ map (infixLiteral . repr) infixes rarg <- optional expr case rarg of- Just (BinaryOpExpr op' _ _)+ Just (InfixExpr op' _ _) | assoc op' /= RightAssoc && priority op >= priority op' -> customFailure (IllFormedSection op op') _ -> return (SectionExpr op Nothing rarg)@@ -459,7 +464,7 @@ larg <- opExpr op <- choice $ map (infixLiteral . repr) infixes case larg of- BinaryOpExpr op' _ _+ InfixExpr op' _ _ | assoc op' /= LeftAssoc && priority op >= priority op' -> customFailure (IllFormedSection op op') _ -> return (SectionExpr op (Just larg) Nothing)@@ -512,7 +517,7 @@ -- Atomic expressions without index atomExpr' :: Parser EgisonExpr-atomExpr' = partialExpr -- must come before |constantExpr|+atomExpr' = anonParamFuncExpr -- must come before |constantExpr| <|> constantExpr <|> FreshVarExpr <$ symbol "#" <|> VarExpr <$> varLiteral@@ -522,14 +527,14 @@ <|> hashExpr <|> QuoteExpr <$> (char '\'' >> atomExpr') -- must come after |constantExpr| <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')- <|> PartialVarExpr <$> try (char '%' >> positiveIntegerLiteral)+ <|> AnonParamExpr <$> try (char '%' >> positiveIntegerLiteral) <?> "atomic expression" -partialExpr :: Parser EgisonExpr-partialExpr = do+anonParamFuncExpr :: Parser EgisonExpr+anonParamFuncExpr = do n <- try (L.decimal <* char '#') -- No space after the index body <- atomExpr -- No space after '#'- return $ PartialExpr n body+ return $ AnonParamFuncExpr n body constantExpr :: Parser EgisonExpr constantExpr = numericExpr@@ -859,7 +864,6 @@ , "capply" , "memoizedLambda" , "cambda"- , "procedure" , "let" , "in" , "where"
hs-src/Language/Egison/Parser/SExpr.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-all #-} -- Since we will soon deprecate this parser {- |@@ -125,9 +126,9 @@ quoteExpr = char '\'' >> QuoteExpr <$> expr' expr' :: Parser EgisonExpr-expr' = try partialExpr+expr' = try anonParamFuncExpr <|> try constantExpr- <|> try partialVarExpr+ <|> try anonParamExpr <|> try freshVarExpr <|> try varExpr <|> inductiveDataExpr@@ -141,7 +142,6 @@ <|> lambdaExpr <|> memoizedLambdaExpr <|> cambdaExpr- <|> procedureExpr <|> patternFunctionExpr <|> letRecExpr <|> letExpr@@ -315,9 +315,6 @@ cambdaExpr :: Parser EgisonExpr cambdaExpr = keywordCambda >> char '$' >> CambdaExpr <$> ident <*> expr -procedureExpr :: Parser EgisonExpr-procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <*> expr- patternFunctionExpr :: Parser EgisonExpr patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern @@ -386,33 +383,33 @@ _ | all null vars -> let n = toInteger (length vars) args' = f args 1- in return $ PartialExpr n $ ApplyExpr func (TupleExpr args')+ in return $ AnonParamFuncExpr n $ ApplyExpr func (TupleExpr args') | all (not . null) vars -> let ns = Set.fromList $ map read vars n = Set.size ns in if Set.findMin ns == 1 && Set.findMax ns == n then let args' = map g args- in return $ PartialExpr (toInteger n) $ ApplyExpr func (TupleExpr args')- else fail "invalid partial application"- | otherwise -> fail "invalid partial application"+ in return $ AnonParamFuncExpr (toInteger n) $ ApplyExpr func (TupleExpr args')+ else fail "invalid anonymous parameter function"+ | otherwise -> fail "invalid anonymous parameter function" where arg = try (Right <$> expr) <|> char '$' *> (Left <$> option "" index) index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit f [] _ = []- f (Left _ : args) n = PartialVarExpr n : f args (n + 1)+ f (Left _ : args) n = AnonParamExpr n : f args (n + 1) f (Right expr : args) n = expr : f args n- g (Left arg) = PartialVarExpr (read arg)+ g (Left arg) = AnonParamExpr (read arg) g (Right expr) = expr -partialExpr :: Parser EgisonExpr-partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> expr)+anonParamFuncExpr :: Parser EgisonExpr+anonParamFuncExpr = (AnonParamFuncExpr . read <$> index) <*> (char '#' >> expr) where index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit -partialVarExpr :: Parser EgisonExpr-partialVarExpr = char '%' >> PartialVarExpr <$> integerLiteral+anonParamExpr :: Parser EgisonExpr+anonParamExpr = char '%' >> AnonParamExpr <$> integerLiteral algebraicDataMatcherExpr :: Parser EgisonExpr algebraicDataMatcherExpr = keywordAlgebraicDataMatcher@@ -650,7 +647,6 @@ , "memoized-lambda" , "memoize" , "cambda"- , "procedure" , "pattern-function" , "letrec" , "let"@@ -724,7 +720,6 @@ keywordMemoizedLambda = reserved "memoized-lambda" keywordMemoize = reserved "memoize" keywordCambda = reserved "cambda"-keywordProcedure = reserved "procedure" keywordPatternFunction = reserved "pattern-function" keywordLetRec = reserved "letrec" keywordLet = reserved "let"@@ -840,12 +835,56 @@ lower :: Parser Char lower = satisfy isLower +renamedFunctions :: [(String, String)]+renamedFunctions =+ [ ("empty?", "isEmpty")+ , ("S.empty?", "S.isEmpty")+ , ("bool?", "isBool")+ , ("integer?", "isInteger")+ , ("rational?", "isRational")+ , ("scalar?", "isScalar")+ , ("float?", "isFloat")+ , ("char?", "isChar")+ , ("string?", "isString")+ , ("collection?", "isCollection")+ , ("hash?", "isHash")+ , ("tensor?", "isTensor")+ , ("even?", "isEven")+ , ("odd?", "isOdd")+ , ("prime?", "isPrime")+ , ("eof?", "isEof")+ , ("eof-port?", "isEofPort")+ , ("alphabet?", "isAlphabet")+ , ("C.between?", "C.isBetween")+ , ("alphabets?", "isAlphabetString")+ , ("include?", "include")+ , ("include/m?", "includeAs")+ , ("member?", "member")+ , ("member/m?", "memberAs")+ , ("divisor?", "divisor")+ , ("tree-member?","treeMember")+ , ("eq/m?", "eqAs")+ , ("eq?", "equal")+ , ("lt?", "lt")+ , ("lte?", "lte")+ , ("gt?", "gt")+ , ("gte?", "gte")+ , ("car", "head")+ , ("cdr", "tail")+ , ("rac", "last")+ , ("rdc", "init")+ ]+ -- Translate identifiers for Non-S syntax toCamelCase :: String -> String toCamelCase "-'" = "-'" toCamelCase "f.-'" = "f.-'" toCamelCase "b.." = "b." toCamelCase "b..'" = "b.'"+toCamelCase (flip lookup renamedFunctions -> Just name') =+ name'+toCamelCase (reverse -> 'm':'/':xs) =+ toCamelCase (reverse xs ++ "-as") toCamelCase x = let heads:tails = splitOn "-" x in concat $ heads : map capitalize tails
hs-src/Language/Egison/Pretty.hs view
@@ -11,6 +11,8 @@ module Language.Egison.Pretty ( prettyTopExprs , PrettyS(..)+ , prettyStr+ , prettyStr' , showTSV ) where @@ -18,10 +20,11 @@ import qualified Data.HashMap.Strict as HashMap import Data.List (intercalate) import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.String (renderString) import qualified Data.Vector as V import Language.Egison.AST-import Language.Egison.MathExpr+import Language.Egison.MathExpr hiding (Printable(..)) import Language.Egison.Data --@@ -78,8 +81,6 @@ lambdaLike (pretty "memoizedLambda ") (map pretty xs) (pretty "->") (pretty e) pretty (CambdaExpr x e) = indentBlock (pretty "cambda" <+> pretty x <+> pretty "->") [pretty e]- pretty (ProcedureExpr xs e) =- lambdaLike (pretty "procedure ") (map pretty xs) (pretty "->") (pretty e) pretty (PatternFunctionExpr xs p) = lambdaLike (pretty "\\") (map pretty xs) (pretty "=>") (pretty p) @@ -124,21 +125,22 @@ pretty (QuoteExpr e) = squote <> pretty' e pretty (QuoteSymbolExpr e) = pretty '`' <> pretty' e - pretty (UnaryOpExpr op x@(IntegerExpr _)) = pretty op <> pretty x- pretty (UnaryOpExpr op x)+ pretty (PrefixExpr op x@(IntegerExpr _)) = pretty op <> pretty x+ pretty (PrefixExpr op x) | isAtomOrApp x = pretty op <+> pretty x | otherwise = pretty op <+> parens (pretty x) -- (x1 op' x2) op y- pretty (BinaryOpExpr op x@(BinaryOpExpr op' _ _) y) =+ pretty (InfixExpr op x@(InfixExpr op' _ _) y) = if priority op > priority op' || priority op == priority op' && assoc op == RightAssoc- then parens (pretty x) <+> pretty op <+> pretty'' y- else pretty x <+> pretty op <+> pretty'' y+ then parens (pretty x) <+> pretty op <> infixRight (pretty'' y)+ else pretty x <+> pretty op <> infixRight (pretty'' y) -- x op (y1 op' y2)- pretty (BinaryOpExpr op x y@(BinaryOpExpr op' _ _)) =+ pretty (InfixExpr op x y@(InfixExpr op' _ _)) = if priority op > priority op' || priority op == priority op' && assoc op == LeftAssoc- then pretty'' x <+> pretty op <+> parens (pretty y)- else pretty'' x <+> pretty op <+> pretty y- pretty (BinaryOpExpr op x y) = pretty'' x <+> pretty op <+> pretty'' y+ then pretty'' x <+> pretty op <> infixRight (parens (pretty y))+ else pretty'' x <+> pretty op <> infixRight (pretty y)+ pretty (InfixExpr op x y) =+ pretty'' x <+> pretty op <> infixRight (pretty'' y) pretty (SectionExpr op Nothing Nothing) = parens (pretty op) pretty (SectionExpr op (Just x) Nothing) = parens (pretty x <+> pretty op) pretty (SectionExpr op Nothing (Just x)) = parens (pretty op <+> pretty x)@@ -154,8 +156,8 @@ pretty (ApplyExpr x (TupleExpr ys)) = applyLike (map pretty' (x : ys)) pretty (ApplyExpr x y) = applyLike [pretty' x, pretty' y] pretty (CApplyExpr e1 e2) = applyLike [pretty "capply", pretty' e1, pretty' e2]- pretty (PartialExpr n e) = pretty n <> pretty '#' <> pretty' e- pretty (PartialVarExpr n) = pretty '%' <> pretty n+ pretty (AnonParamFuncExpr n e) = pretty n <> pretty '#' <> pretty' e+ pretty (AnonParamExpr n) = pretty '%' <> pretty n pretty (GenerateTensorExpr gen shape) = applyLike [pretty "generateTensor", pretty' gen, pretty' shape]@@ -184,9 +186,13 @@ pretty (TensorArg x) = pretty '%' <> pretty x instance Pretty Var where- -- TODO: indices- pretty (Var xs _) = concatWith (surround dot) (map pretty xs)+ pretty (Var xs is) =+ concatWith (surround dot) (map pretty xs) <> hcat (map pretty is) +instance Pretty VarWithIndices where+ pretty (VarWithIndices xs is) =+ concatWith (surround dot) (map pretty xs) <> hcat (map pretty is)+ instance Pretty InnerExpr where pretty (ElementExpr x) = pretty x pretty (SubCollectionExpr _) = error "Not supported"@@ -201,6 +207,22 @@ pretty (pat, expr) = pipe <+> align (pretty pat) <+> indentBlock (pretty "->") [pretty expr] +instance {-# OVERLAPPING #-} Pretty (Index ()) where -- Used for 'Var'+ pretty Subscript{} = pretty '_'+ pretty Superscript{} = pretty '~'+ pretty SupSubscript{} = pretty "~_"+ pretty DFscript{} = pretty ""+ pretty Userscript{} = pretty '|'+ pretty _ = undefined++instance {-# OVERLAPPING #-} Pretty (Index String) where -- for 'VarWithIndices'+ pretty (Superscript s) = pretty ("~" ++ s)+ pretty (Subscript s) = pretty ("_" ++ s)+ pretty (SupSubscript s) = pretty ("~_" ++ s)+ pretty (DFscript _ _) = pretty ""+ pretty (Userscript i) = pretty ("|" ++ show i)+ pretty _ = undefined+ instance (Pretty a, Complex a) => Pretty (Index a) where pretty (Subscript i) = pretty '_' <> pretty' i pretty (Superscript i) = pretty '~' <> pretty' i@@ -254,7 +276,7 @@ instance Pretty LoopRange where pretty (LoopRange from (ApplyExpr (VarExpr (Var ["from"] []))- (BinaryOpExpr (Infix { repr = "-'" }) _ (IntegerExpr 1))) pat) =+ (InfixExpr (Infix { repr = "-'" }) _ (IntegerExpr 1))) pat) = tupled [pretty from, pretty pat] pretty (LoopRange from to pat) = tupled [pretty from, pretty to, pretty pat] @@ -288,13 +310,14 @@ isAtom (IntegerExpr i) | i < 0 = False isAtom (InductiveDataExpr _ []) = True isAtom (InductiveDataExpr _ _) = False- isAtom UnaryOpExpr{} = False- isAtom BinaryOpExpr{} = False+ isAtom PrefixExpr{} = False+ isAtom InfixExpr{} = False isAtom ApplyExpr{} = False isAtom CApplyExpr{} = False isAtom LambdaExpr{} = False+ isAtom MemoizedLambdaExpr{} = False isAtom CambdaExpr{} = False- isAtom ProcedureExpr{} = False+ isAtom PatternFunctionExpr{} = False isAtom IfExpr{} = False isAtom LetRecExpr{} = False isAtom SubrefsExpr{} = False@@ -320,8 +343,8 @@ isAtomOrApp InductiveDataExpr{} = True isAtomOrApp e = isAtom e - isInfix BinaryOpExpr{} = True- isInfix _ = False+ isInfix InfixExpr{} = True+ isInfix _ = False instance Complex EgisonPattern where isAtom (LetPat _ _) = False@@ -402,40 +425,28 @@ applyLike :: [Doc ann] -> Doc ann applyLike = hang 2 . sep . map group +-- Tests if the argument can be printed in a single line, and if not,+-- inserts a line break before printing it.+-- This is useful for nicely printing infix expressions.+infixRight :: Doc ann -> Doc ann+infixRight p = group (flatAlt (hardline <> p) (space <> p))+ ----- Pretty printer for S-expression+-- Pretty printer for error messages -- -class PrettyS a where- prettyS :: a -> String--instance PrettyS EgisonExpr where- prettyS (CharExpr c) = "c#" ++ [c]- prettyS (StringExpr str) = show str- prettyS (BoolExpr True) = "#t"- prettyS (BoolExpr False) = "#f"- prettyS (IntegerExpr n) = show n- prettyS (FloatExpr x) = show x- prettyS (VarExpr name) = prettyS name- prettyS (PartialVarExpr n) = "%" ++ show n- prettyS (FunctionExpr args) = "(function [" ++ unwords (map prettyS args) ++ "])"- prettyS (IndexedExpr True expr idxs) = prettyS expr ++ concatMap prettyS idxs- prettyS (IndexedExpr False expr idxs) = prettyS expr ++ "..." ++ concatMap prettyS idxs- prettyS (TupleExpr exprs) = "[" ++ unwords (map prettyS exprs) ++ "]"- prettyS (CollectionExpr ls) = "{" ++ unwords (map prettyS ls) ++ "}"+prettyStr :: Pretty a => a -> String+prettyStr = renderString . layoutPretty (LayoutOptions Unbounded) . pretty - prettyS (UnaryOpExpr op e) = op ++ " " ++ prettyS e- prettyS (BinaryOpExpr op e1 e2) = "(" ++ prettyS e1 ++ " " ++ prettyS op ++ " " ++ prettyS e2 ++ ")"+prettyStr' :: (Pretty a, Complex a) => a -> String+prettyStr' = renderString . layoutPretty (LayoutOptions Unbounded) . pretty' - prettyS (QuoteExpr e) = "'" ++ prettyS e- prettyS (QuoteSymbolExpr e) = "`" ++ prettyS e+--+-- Pretty printer for S-expression+-- - prettyS (ApplyExpr fn (TupleExpr [])) = "(" ++ prettyS fn ++ ")"- prettyS (ApplyExpr fn (TupleExpr args)) = "(" ++ prettyS fn ++ " " ++ unwords (map prettyS args) ++ ")"- prettyS (ApplyExpr fn arg) = "(" ++ prettyS fn ++ " " ++ prettyS arg ++ ")"- prettyS (VectorExpr xs) = "[| " ++ unwords (map prettyS xs) ++ " |]"- prettyS (WithSymbolsExpr xs e) = "(withSymbols {" ++ unwords xs ++ "} " ++ prettyS e ++ ")"- prettyS _ = "(not supported)"+class PrettyS a where+ prettyS :: a -> String instance PrettyS EgisonValue where prettyS (Char c) = "c#" ++ [c]@@ -460,13 +471,11 @@ prettyS UserMatcher{} = "#<user-matcher>" prettyS (Func Nothing _ args _) = "(lambda [" ++ unwords (map ('$':) args) ++ "] ...)" prettyS (Func (Just name) _ _ _) = prettyS name- prettyS (PartialFunc _ n expr) = show n ++ "#" ++ prettyS expr+ prettyS (AnonParamFunc _ n _) = show n ++ "#(...)" prettyS (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)" prettyS (CFunc (Just name) _ _ _) = prettyS name prettyS (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)" prettyS (MemoizedFunc (Just name) _ _ _ _ _) = prettyS name- prettyS (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)"- prettyS (Proc (Just name) _ _ _) = name prettyS PatternFunc{} = "#<pattern-function>" prettyS (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">" prettyS (IOFunc _) = "#<io-function>"@@ -479,21 +488,6 @@ instance PrettyS Var where prettyS = show -instance PrettyS VarWithIndices where- prettyS = show--instance PrettyS Infix where- prettyS = repr--instance PrettyS InnerExpr where- prettyS (ElementExpr e) = prettyS e- prettyS (SubCollectionExpr e) = '@' : prettyS e--instance PrettyS Arg where- prettyS (ScalarArg name) = "$" ++ name- prettyS (InvertedScalarArg name) = "*$" ++ name- prettyS (TensorArg name) = "%" ++ name- instance PrettyS ScalarData where prettyS (Div p1 (Plus [Term 1 []])) = prettyS p1 prettyS (Div p1 p2) = "(/ " ++ prettyS p1 ++ " " ++ prettyS p2 ++ ")"@@ -547,43 +541,3 @@ prettyS (Userscript i) = case i of ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]" _ -> "|" ++ prettyS i--instance PrettyS EgisonPattern where- prettyS WildCard = "_"- prettyS (PatVar var) = "$" ++ prettyS var- prettyS (ValuePat expr) = "," ++ prettyS expr- prettyS (PredPat expr) = "?" ++ prettyS expr- prettyS (IndexedPat pat exprs) = prettyS pat ++ concatMap (("_" ++) . prettyS) exprs- prettyS (LetPat bexprs pat) =- "(let {" ++ unwords (map (\(vars, expr) -> "[" ++ varsHelper vars ++ " " ++ prettyS expr ++ "]") bexprs) ++- "} " ++ prettyS pat ++ ")"- where varsHelper [] = ""- varsHelper [v] = "$" ++ prettyS v- varsHelper vs = "[" ++ unwords (map (("$" ++) . prettyS) vs) ++ "]"- prettyS (NotPat pat) = "!" ++ prettyS pat- prettyS (AndPat pats) = "(&" ++ concatMap ((" " ++) . prettyS) pats ++ ")"- prettyS (OrPat pats) = "(|" ++ concatMap ((" " ++) . prettyS) pats ++ ")"- prettyS (TuplePat pats) = "[" ++ unwords (map prettyS pats) ++ "]"- prettyS (InductivePat name pats) = "<" ++ name ++ concatMap ((" " ++) . prettyS) pats ++ ">"- prettyS (LoopPat var range pat endPat) = "(loop $" ++ unwords [prettyS var, prettyS range, prettyS pat, prettyS endPat] ++ ")"- prettyS ContPat = "..."- prettyS (PApplyPat expr pats) = "(" ++ unwords (prettyS expr : map prettyS pats) ++ ")"- prettyS (VarPat name) = name- prettyS SeqNilPat = "{}"- prettyS (SeqConsPat pat pat') = "{" ++ prettyS pat ++ seqPatHelper pat' ++ "}"- where seqPatHelper SeqNilPat = ""- seqPatHelper (SeqConsPat pat pat') = " " ++ prettyS pat ++ seqPatHelper pat'- seqPatHelper pat = " " ++ prettyS pat- prettyS LaterPatVar = "#"-- prettyS (DApplyPat pat pats) = "(" ++ unwords (prettyS pat : map prettyS pats) ++ ")"- prettyS (DivPat pat pat') = "(/ " ++ prettyS pat ++ " " ++ prettyS pat' ++ ")"- prettyS (PlusPat pats) = "(+" ++ concatMap ((" " ++) . prettyS) pats- prettyS (MultPat pats) = "(*" ++ concatMap ((" " ++) . prettyS) pats- prettyS (PowerPat pat pat') = "(" ++ prettyS pat ++ " ^ " ++ prettyS pat' ++ ")"- prettyS _ = "(not supported)"--instance PrettyS LoopRange where- prettyS (LoopRange start (ApplyExpr (VarExpr (Var ["from"] [])) (ApplyExpr _ (TupleExpr (x:_)))) endPat) =- "[" ++ show start ++ " (from " ++ show x ++ ") " ++ prettyS endPat ++ "]"- prettyS (LoopRange start ends endPat) = "[" ++ show start ++ " " ++ show ends ++ " " ++ prettyS endPat ++ "]"
+ hs-src/Language/Egison/PrettyMath/AST.hs view
@@ -0,0 +1,111 @@+{- |+Module : Language.Egison.PrettyMath.AST+Licence : MIT+-}++module Language.Egison.PrettyMath.AST+ ( MathExpr(..)+ , MathIndex(..)+ , isSub+ , parseExpr+ ) where++import Text.ParserCombinators.Parsec hiding (spaces)++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)++isSub :: MathIndex -> Bool+isSub (Sub _) = True+isSub _ = False++--+-- Parser+--++spaces :: Parser ()+spaces = skipMany1 space++spaces0 :: Parser ()+spaces0 = skipMany space++symbol :: Parser Char+symbol = oneOf "!$%&*+-/:<=>?@#"++parseAtom :: Parser MathExpr+parseAtom = Atom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol)) <*> many parseScript++parseAtom' :: Parser MathExpr+parseAtom' = flip Atom [] <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol))++parsePartial :: Parser MathExpr+parsePartial = Partial <$> parseAtom <*> many1 (char '|' >> parseAtom)++parseNegativeAtom :: Parser MathExpr+parseNegativeAtom = char '-' >> NegativeAtom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol))++parseList :: Parser [MathExpr]+parseList = sepEndBy parseExpr spaces++parseScript :: Parser MathIndex+parseScript = Sub <$> (char '_' >> parseAtom')+ <|> Super <$> (char '~' >> parseAtom')++parsePlus :: Parser MathExpr+parsePlus = string "(+" >> spaces >> Plus <$> parseList <* char ')'++parseMultiply :: Parser MathExpr+parseMultiply = string "(*" >> spaces >> Multiply <$> parseList <* char ')'++parseFunction :: Parser MathExpr+parseFunction = char '(' >> Func <$> parseAtom <* spaces <*> parseList <* char ')'++parseTensor :: Parser MathExpr+parseTensor = string "[|" >> spaces0 >> Tensor <$> parseList <* spaces0 <* string "|]" <*> many parseScript++parseTuple :: Parser MathExpr+parseTuple = char '[' >> Tuple <$> parseList <* char ']'++parseCollection :: Parser MathExpr+parseCollection = char '{' >> Collection <$> parseList <* char '}'++parseExp :: Parser MathExpr+parseExp = string "(exp" >> spaces >> Exp <$> parseExpr <* char ')'++parseQuote :: Parser MathExpr+parseQuote = char '\'' >> Quote <$> parseExpr'++parseExpr' :: Parser MathExpr+parseExpr' = parseNegativeAtom+ <|> try parsePartial+ <|> parseAtom+ <|> parseQuote+ <|> try parseExp+ <|> try parsePlus+ <|> try parseMultiply+ <|> try parseFunction+ <|> try parseTensor+ <|> try parseTuple+ <|> try parseCollection++parseExpr :: Parser MathExpr+parseExpr = do+ x <- parseExpr'+ option x $ Power x <$> try (char '^' >> parseExpr')
+ hs-src/Language/Egison/PrettyMath/AsciiMath.hs view
@@ -0,0 +1,57 @@+{- |+Module : Language.Egison.PrettyMath.AsciiMath+Licence : MIT+-}++module Language.Egison.PrettyMath.AsciiMath+ ( showMathExpr+ ) where++import Data.List (intercalate)++import Language.Egison.PrettyMath.AST++showMathExpr :: MathExpr -> String+showMathExpr (Atom func []) = func+showMathExpr (NegativeAtom func) = "-" ++ func+showMathExpr (Plus []) = ""+showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs+ where+ showMathExprForPlus :: [MathExpr] -> String+ showMathExprForPlus [] = ""+ showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ " " ++ showMathExprForPlus xs+ showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs+showMathExpr (Multiply []) = ""+showMathExpr (Multiply [a]) = showMathExpr a+showMathExpr (Multiply (NegativeAtom "1":lvs)) = "-" ++ showMathExpr (Multiply lvs)+showMathExpr (Multiply lvs) = showMathExpr' (head lvs) ++ " " ++ showMathExpr (Multiply (tail lvs))+showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2+showMathExpr (Func (Atom "sqrt" []) [x]) = "sqrt " ++ showMathExpr x+showMathExpr (Func (Atom "rt" []) [x, y]) = "root " ++ showMathExpr x ++ " " ++ showMathExpr y+showMathExpr (Func (Atom "/" []) [x, y]) = "frac{" ++ showMathExpr x ++ "}{" ++ showMathExpr y ++ "}"+showMathExpr (Func f lvs) = showMathExpr f ++ "(" ++ showMathExprArg lvs ++ ")"+showMathExpr (Tensor lvs mis)+ | null mis = "(" ++ showMathExprArg lvs ++ ")"+ | not (any isSub mis) = "(" ++ showMathExprArg lvs ++ ")^(" ++ showMathExprIndices mis ++ ")"+ | not (any (not . isSub) mis) = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices mis ++ ")"+ | otherwise = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")"+showMathExpr (Tuple lvs) = "(" ++ showMathExprArg lvs ++ ")"+showMathExpr (Collection lvs) = "{" ++ showMathExprArg lvs ++ "}"+showMathExpr (Exp x) = "e^(" ++ showMathExpr x ++ ")"++showMathExpr' :: MathExpr -> String+showMathExpr' (Plus lvs) = "(" ++ showMathExpr (Plus lvs) ++ ")"+showMathExpr' val = showMathExpr val++showMathExprArg :: [MathExpr] -> String+showMathExprArg exprs = intercalate ", " $ map showMathExpr exprs++showMathExprIndices :: [MathIndex] -> String+showMathExprIndices [] = error "unreachable"+showMathExprIndices lvs = concatMap showMathIndex lvs++showMathIndex :: MathIndex -> String+showMathIndex (Super a) = showMathExpr a+showMathIndex (Sub a) = showMathExpr a
+ hs-src/Language/Egison/PrettyMath/Latex.hs view
@@ -0,0 +1,83 @@+{- |+Module : Language.Egison.PrettyMath.Latex+Licence : MIT+-}++module Language.Egison.PrettyMath.Latex+ ( showMathExpr+ ) where++import Data.List (intercalate)++import Language.Egison.PrettyMath.AST++showMathExpr :: MathExpr -> String+showMathExpr (Atom a []) = a+showMathExpr (Atom a xs) = a ++ showMathExprScript xs+showMathExpr (Partial f xs) = "\\frac{" ++ convertToPartial (f, length xs) ++ "}{" ++ showPartial xs ++ "}"+ where+ showPartial :: [MathExpr] -> String+ showPartial xs = let lx = elemCount xs in convertToPartial2 (head lx) ++ foldr (\x acc -> " " ++ convertToPartial2 x ++ acc) "" (tail lx)++ convertToPartial :: (MathExpr, Int) -> String+ convertToPartial (x, 1) = "\\partial " ++ showMathExpr x+ convertToPartial (x, n) = "\\partial^" ++ show n ++ " " ++ showMathExpr x++ convertToPartial2 :: (MathExpr, Int) -> String+ convertToPartial2 (x, 1) = "\\partial " ++ showMathExpr x+ convertToPartial2 (x, n) = "\\partial " ++ showMathExpr x ++ "^" ++ show n+showMathExpr (NegativeAtom a) = "-" ++ a+showMathExpr (Plus []) = ""+showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs+ where+ showMathExprForPlus :: [MathExpr] -> String+ showMathExprForPlus [] = ""+ showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs+ showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs+showMathExpr (Multiply []) = ""+showMathExpr (Multiply [x]) = showMathExpr x+showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs)+showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs)+showMathExpr (Multiply (x:xs)) = showMathExpr' x ++ " " ++ showMathExpr (Multiply xs)+showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2+showMathExpr (Func (Atom "sqrt" []) [x]) = "\\sqrt{" ++ showMathExpr x ++ "}"+showMathExpr (Func (Atom "rt" []) [x, y]) = "\\sqrt[" ++ showMathExpr x ++ "]{" ++ showMathExpr y ++ "}"+showMathExpr (Func (Atom "/" []) [x, y]) = "\\frac{" ++ showMathExpr x ++ "}{" ++ showMathExpr y ++ "}"+showMathExpr (Func f xs) = showMathExpr f ++ "(" ++ showMathExprArg xs ", " ++ ")"+showMathExpr (Tensor xs mis) = "\\begin{pmatrix} " ++ showMathExprVectors xs ++ "\\end{pmatrix}" ++ showMathExprScript mis+showMathExpr (Tuple xs) = "(" ++ showMathExprArg xs ", " ++ ")"+showMathExpr (Collection xs) = "\\{" ++ showMathExprArg xs ", " ++ "\\}"+showMathExpr (Exp x) = "e^{" ++ showMathExpr x ++ "}"+showMathExpr (Quote x) = "(" ++ showMathExpr x ++ ")"++showMathExpr' :: MathExpr -> String+showMathExpr' (Plus xs) = "(" ++ showMathExpr (Plus xs) ++ ")"+showMathExpr' x = showMathExpr x++showMathExprArg :: [MathExpr] -> String -> String+showMathExprArg exprs sep = intercalate sep $ map showMathExpr exprs++showMathExprSuper :: MathIndex -> String+showMathExprSuper (Super (Atom "#" [])) = "\\#"+showMathExprSuper (Super x) = showMathExpr x+showMathExprSuper (Sub _) = "\\;"++showMathExprSub :: MathIndex -> String+showMathExprSub (Sub (Atom "#" [])) = "\\#"+showMathExprSub (Sub x) = showMathExpr x+showMathExprSub (Super _) = "\\;"++showMathExprScript :: [MathIndex] -> String+showMathExprScript [] = ""+showMathExprScript is = "_{" ++ concatMap showMathExprSub is ++ "}^{" ++ concatMap showMathExprSuper is ++ "}"++showMathExprVectors :: [MathExpr] -> String+showMathExprVectors [] = ""+showMathExprVectors (Tensor lvs []:r) = showMathExprArg lvs " & " ++ " \\\\ " ++ showMathExprVectors r+showMathExprVectors lvs = showMathExprArg lvs " \\\\ " ++ "\\\\ "++elemCount :: Eq a => [a] -> [(a, Int)]+elemCount [] = []+elemCount (x:xs) = (x, length (filter (== x) xs) + 1) : elemCount (filter (/= x) xs)
+ hs-src/Language/Egison/PrettyMath/Mathematica.hs view
@@ -0,0 +1,67 @@+{- |+Module : Language.Egison.PrettyMath.Mathematica+Licence : MIT+-}++module Language.Egison.PrettyMath.Mathematica+ ( showMathExpr+ ) where++import Data.List (intercalate)++import Language.Egison.PrettyMath.AST++showMathExpr :: MathExpr -> String+showMathExpr (Atom a []) = a+showMathExpr (Atom a xs) = a ++ showMathExprIndices xs+showMathExpr (Partial f xs) = showMathExpr f ++ "_" ++ showMathExprs "_" xs+showMathExpr (NegativeAtom a) = "-" ++ a+showMathExpr (Plus []) = ""+showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs+ where+ showMathExprForPlus :: [MathExpr] -> String+ showMathExprForPlus [] = ""+ showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs+ showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs+showMathExpr (Multiply []) = ""+showMathExpr (Multiply [x]) = showMathExpr x+showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs)+showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs)+showMathExpr (Multiply (x:xs)) = showMathExpr' x ++ " " ++ showMathExpr (Multiply xs)+showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2+showMathExpr (Func (Atom "sqrt" []) [x]) = "Sqrt[" ++ showMathExpr x ++ "]"+showMathExpr (Func (Atom "rt" []) [x, y]) = "Surd[" ++ showMathExpr x ++ "," ++ showMathExpr y ++ "]"+showMathExpr (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y+ where+ addBracket x@(Atom _ []) = showMathExpr x+ addBracket x = "(" ++ showMathExpr x ++ ")"+showMathExpr (Func f xs) = showMathExpr f ++ "(" ++ showMathExprArg xs ++ ")"+showMathExpr (Tensor lvs mis)+ | null mis = "{" ++ showMathExprArg lvs ++ "}"+ | not (any isSub mis) = "{" ++ showMathExprArg lvs ++ "}^(" ++ showMathExprIndices mis ++ ")"+ | not (any (not . isSub) mis) = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices mis ++ ")"+ | otherwise = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")"+showMathExpr (Tuple xs) = "(" ++ showMathExprArg xs ++ ")"+showMathExpr (Collection xs) = "{" ++ showMathExprArg xs ++ "}"+showMathExpr (Exp x) = "e^(" ++ showMathExpr x ++ ")"+showMathExpr (Quote x) = "(" ++ showMathExpr x ++ ")"++showMathExpr' :: MathExpr -> String+showMathExpr' (Plus xs) = "(" ++ showMathExpr (Plus xs) ++ ")"+showMathExpr' x = showMathExpr x++showMathExprs :: String -> [MathExpr] -> String+showMathExprs sep exprs = intercalate sep $ map showMathExpr exprs++showMathExprArg :: [MathExpr] -> String+showMathExprArg = showMathExprs ", "++showMathExprIndices :: [MathIndex] -> String+showMathExprIndices [] = error "unreachable"+showMathExprIndices lvs = concatMap showMathIndex lvs++showMathIndex :: MathIndex -> String+showMathIndex (Super a) = showMathExpr a+showMathIndex (Sub a) = showMathExpr a
+ hs-src/Language/Egison/PrettyMath/Maxima.hs view
@@ -0,0 +1,52 @@+{- |+Module : Language.Egison.PrettyMath.Maxima+Licence : MIT+-}++module Language.Egison.PrettyMath.Maxima+ ( showMathExpr+ ) where++import Language.Egison.PrettyMath.AST++showMathExpr :: MathExpr -> String+showMathExpr (Atom a []) = a+showMathExpr (Partial _ _) = "undefined"+showMathExpr (NegativeAtom a) = "-" ++ a+showMathExpr (Plus []) = ""+showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs+ where+ showMathExprForPlus :: [MathExpr] -> String+ showMathExprForPlus [] = ""+ showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs+ showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs+ showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs+showMathExpr (Multiply []) = ""+showMathExpr (Multiply [x]) = showMathExpr x+showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs)+showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs)+showMathExpr (Multiply (x:xs)) = showMathExpr' x ++ " * " ++ showMathExpr (Multiply xs)+showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2+showMathExpr (Func (Atom "sqrt" []) [x]) = "sqrt(" ++ showMathExpr x ++ ")"+showMathExpr (Func (Atom "rt" []) [x, y]) = showMathExpr y ++ "^(1/" ++ showMathExpr x ++ ")"+showMathExpr (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y+ where+ addBracket x@(Atom _ []) = showMathExpr x+ addBracket x = "(" ++ showMathExpr x ++ ")"+showMathExpr (Func f xs) = showMathExpr f ++ "(" ++ showMathExprArg xs ++ ")"+showMathExpr (Tensor _ _) = "undefined"+showMathExpr (Tuple _) = "undefined"+showMathExpr (Collection xs) = "[" ++ showMathExprArg xs ++ "]"+showMathExpr (Exp x) = "exp(" ++ showMathExpr x ++ ")"+showMathExpr (Quote x) = "(" ++ showMathExpr x ++ ")"++showMathExpr' :: MathExpr -> String+showMathExpr' x@(Plus _) = "(" ++ showMathExpr x ++ ")"+showMathExpr' x = showMathExpr x++showMathExprArg :: [MathExpr] -> String+showMathExprArg [] = ""+showMathExprArg [Tensor _ []] = "undefined"+showMathExprArg [a] = showMathExpr a+showMathExprArg lvs = showMathExpr (head lvs) ++ ", " ++ showMathExprArg (tail lvs)
hs-src/Language/Egison/Primitives.hs view
@@ -41,7 +41,7 @@ import Language.Egison.AST import Language.Egison.Core import Language.Egison.Data-import Language.Egison.IState (MonadFresh(..))+import Language.Egison.IState (MonadEval(..)) import Language.Egison.Parser import Language.Egison.Pretty import Language.Egison.MathExpr@@ -65,7 +65,7 @@ return $ extendEnv nullEnv bindings {-# INLINE noArg #-}-noArg :: EgisonM EgisonValue -> PrimitiveFunc+noArg :: EvalM EgisonValue -> PrimitiveFunc noArg f args = do args' <- tupleToList args case args' of@@ -73,7 +73,7 @@ _ -> throwError =<< ArgumentsNumPrimitive 0 (length args') <$> getFuncNameStack {-# INLINE oneArg #-}-oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+oneArg :: (EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc oneArg f arg = do arg' <- evalWHNF arg case arg' of@@ -83,13 +83,13 @@ _ -> Value <$> f arg' {-# INLINE oneArg' #-}-oneArg' :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+oneArg' :: (EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc oneArg' f arg = do arg' <- evalWHNF arg Value <$> f arg' {-# INLINE twoArgs #-}-twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+twoArgs :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc twoArgs f args = do args' <- tupleToList args case args' of@@ -104,7 +104,7 @@ _ -> throwError =<< ArgumentsNumPrimitive 2 (length args') <$> getFuncNameStack {-# INLINE twoArgs' #-}-twoArgs' :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+twoArgs' :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc twoArgs' f args = do args' <- tupleToList args case args' of@@ -112,7 +112,7 @@ _ -> throwError =<< ArgumentsNumPrimitive 2 (length args') <$> getFuncNameStack {-# INLINE threeArgs' #-}-threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc threeArgs' f args = do args' <- tupleToList args case args' of@@ -306,8 +306,8 @@ scalarCompare cmp = twoArgs' $ \val1 val2 -> case (val1, val2) of (ScalarData _, ScalarData _) -> do- r1 <- fromEgison val1 :: EgisonM Rational- r2 <- fromEgison val2 :: EgisonM Rational+ r1 <- fromEgison val1 :: EvalM Rational+ r2 <- fromEgison val2 :: EvalM Rational return $ Bool (cmp r1 r2) (Float f1, Float f2) -> return $ Bool (cmp f1 f2) (ScalarData _, _) -> throwError =<< TypeMismatch "number" (Value val2) <$> getFuncNameStack@@ -380,7 +380,7 @@ str <- packStringValue val return $ String str where- packStringValue :: EgisonValue -> EgisonM Text+ packStringValue :: EgisonValue -> EvalM Text packStringValue (Collection seq) = do let ls = toList seq str <- mapM fromEgison ls@@ -545,12 +545,16 @@ , ("rand", randRange) , ("f.rand", randRangeDouble)++ , ("newIORef", newIORef')+ , ("writeIORef", writeIORef')+ , ("readIORef", readIORef') ] -makeIO :: EgisonM EgisonValue -> EgisonValue+makeIO :: EvalM EgisonValue -> EgisonValue makeIO m = IOFunc $ fmap (Value . Tuple . (World :) . (:[])) m -makeIO' :: EgisonM () -> EgisonValue+makeIO' :: EvalM () -> EgisonValue makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []]) return' :: PrimitiveFunc@@ -632,17 +636,34 @@ randRange :: PrimitiveFunc randRange = twoArgs' $ \val val' -> do- i <- fromEgison val :: EgisonM Integer- i' <- fromEgison val' :: EgisonM Integer+ i <- fromEgison val :: EvalM Integer+ i' <- fromEgison val' :: EvalM Integer n <- liftIO $ getStdRandom $ randomR (i, i') return $ makeIO $ return $ toEgison n randRangeDouble :: PrimitiveFunc randRangeDouble = twoArgs' $ \val val' -> do- i <- fromEgison val :: EgisonM Double- i' <- fromEgison val' :: EgisonM Double+ i <- fromEgison val :: EvalM Double+ i' <- fromEgison val' :: EvalM Double n <- liftIO $ getStdRandom $ randomR (i, i') return $ makeIO $ return $ toEgison n++newIORef' :: PrimitiveFunc+newIORef' = noArg $ do+ ref <- liftIO $ newIORef Undefined+ return $ makeIO $ return (RefBox ref)++writeIORef' :: PrimitiveFunc+writeIORef' = twoArgs $ \ref val -> do+ ref' <- fromEgison ref+ return $ makeIO' $ liftIO $ writeIORef ref' val++readIORef' :: PrimitiveFunc+readIORef' = oneArg $ \ref -> do+ ref' <- fromEgison ref+ val <- liftIO $ readIORef ref'+ return $ makeIO $ return val+ {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc
hs-src/Language/Egison/Tensor.hs view
@@ -74,7 +74,7 @@ tIndex (Tensor _ _ js) = js tIndex (Scalar _) = [] -tIntRef' :: HasTensor a => Integer -> Tensor a -> EgisonM a+tIntRef' :: HasTensor a => Integer -> Tensor a -> EvalM a tIntRef' i (Tensor [n] xs _) = if 0 < i && i <= n then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1)@@ -87,7 +87,7 @@ else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack tIntRef' _ _ = throwError $ Default "More indices than the order of the tensor" -tIntRef :: HasTensor a => [Integer] -> Tensor a -> EgisonM (Tensor a)+tIntRef :: HasTensor a => [Integer] -> Tensor a -> EvalM (Tensor a) tIntRef [] (Tensor [] xs _) | V.length xs == 1 = return $ Scalar (xs V.! 0) | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack@@ -95,17 +95,29 @@ tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms -- TODO(momohatt): Refactor.-tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM a+tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EvalM a tref [] (Tensor [] xs _) | V.length xs == 1 = fromTensor $ Scalar (xs V.! 0) | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack tref [] t = fromTensor t-tref (Subscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (Subscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms-tref (Superscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (Superscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms-tref (SupSubscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (SupSubscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms+tref (s@(Subscript (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do+ let yss = split (product ns) xs+ ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss+ mapM toTensor ts >>= tConcat s >>= fromTensor+tref (s@(Superscript (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do+ let yss = split (product ns) xs+ ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss+ mapM toTensor ts >>= tConcat s >>= fromTensor+tref (s@(SupSubscript (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do+ let yss = split (product ns) xs+ ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss+ mapM toTensor ts >>= tConcat s >>= fromTensor+tref (Subscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref (Superscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref (SupSubscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref (Subscript (ScalarData ZeroExpr):_) _ = throwError $ Default "tensor index out of bounds: 0"+tref (Superscript (ScalarData ZeroExpr):_) _ = throwError $ Default "tensor index out of bounds: 0"+tref (SupSubscript (ScalarData ZeroExpr):_) _ = throwError $ Default "tensor index out of bounds: 0" tref (Subscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do m <- fromEgison mVal n <- fromEgison nVal@@ -136,11 +148,7 @@ ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n] symId <- fresh tConcat (SupSubscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor-tref (s:ms) (Tensor (_:ns) xs js) = do- let yss = split (product ns) xs- ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss- mapM toTensor ts >>= tConcat s >>= fromTensor-tref _ _ = throwError $ Default "More indices than the order of the tensor"+tref (_:_) _ = throwError $ Default "Tensor index must be an integer or a single symbol." -- Enumarates all indices (1-indexed) from shape -- ex.@@ -155,14 +163,14 @@ changeIndex (Subscript s) m = Subscript (s ++ show m) -- transIndex [a, b, c] [c, a, b] [2, 3, 4] = [4, 2, 3]-transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer]+transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EvalM [Integer] transIndex is js ns = do mapM (\j -> matchDFS (zip is ns) (List (Pair Eql M.Something)) [[mc| _ ++ (#j, $n) : _ -> return n |] ,[mc| _ -> throwError $ Default "cannot transpose becuase of the inconsitent symbolic tensor indices" |]]) js -tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a)+tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EvalM (Tensor a) tTranspose is t@(Tensor ns _ js) = if length is <= length js then do let js' = take (length is) js@@ -173,7 +181,7 @@ return $ Tensor ns' xs' is else return t -tTranspose' :: HasTensor a => [EgisonValue] -> Tensor a -> EgisonM (Tensor a)+tTranspose' :: HasTensor a => [EgisonValue] -> Tensor a -> EvalM (Tensor a) tTranspose' is t@(Tensor _ _ js) = do case g is js of Nothing -> return t@@ -190,14 +198,14 @@ Just j' -> do js' <- g is js return $ j':js' -tFlipIndices :: HasTensor a => Tensor a -> EgisonM (Tensor a)+tFlipIndices :: HasTensor a => Tensor a -> EvalM (Tensor a) tFlipIndices (Tensor ns xs js) = return $ Tensor ns xs (map flipIndex js) where flipIndex (Subscript i) = Superscript i flipIndex (Superscript i) = Subscript i flipIndex x = x -appendDFscripts :: Integer -> WHNFData -> EgisonM WHNFData+appendDFscripts :: Integer -> WHNFData -> EvalM WHNFData appendDFscripts id (Intermediate (ITensor (Tensor s xs is))) = do let k = fromIntegral (length s - length is) return $ Intermediate (ITensor (Tensor s xs (is ++ map (DFscript id) [1..k])))@@ -206,7 +214,7 @@ return $ Value (TensorData (Tensor s xs (is ++ map (DFscript id) [1..k]))) appendDFscripts _ whnf = return whnf -removeDFscripts :: WHNFData -> EgisonM WHNFData+removeDFscripts :: WHNFData -> EvalM WHNFData removeDFscripts (Intermediate (ITensor (Tensor s xs is))) = do let (ds, js) = partition isDF is Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is)@@ -223,7 +231,7 @@ isDF _ = False removeDFscripts whnf = return whnf -tMap :: HasTensor a => (a -> EgisonM a) -> Tensor a -> EgisonM (Tensor a)+tMap :: HasTensor a => (a -> EvalM a) -> Tensor a -> EvalM (Tensor a) tMap f (Tensor ns xs js') = do let k = fromIntegral $ length ns - length js' let js = js' ++ map (DFscript 0) [1..k]@@ -237,13 +245,13 @@ _ -> return $ Tensor ns xs' js tMap f (Scalar x) = Scalar <$> f x -tMapN :: HasTensor a => ([a] -> EgisonM a) -> [Tensor a] -> EgisonM (Tensor a)+tMapN :: HasTensor a => ([a] -> EvalM a) -> [Tensor a] -> EvalM (Tensor a) tMapN f ts@(Tensor ns _ js : _) = do xs' <- mapM (\is -> mapM (tIntRef is) ts >>= mapM fromTensor >>= f) (enumTensorIndices ns) return $ Tensor ns (V.fromList xs') js tMapN f xs = Scalar <$> (mapM fromTensor xs >>= f) -tMap2 :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)+tMap2 :: HasTensor a => (a -> a -> EvalM a) -> Tensor a -> Tensor a -> EvalM (Tensor a) tMap2 f (Tensor ns1 xs1 js1') (Tensor ns2 xs2 js2') = do let k1 = fromIntegral $ length ns1 - length js1' let js1 = js1' ++ map (DFscript 0) [1..k1]@@ -269,7 +277,7 @@ tMap2 f (Scalar x) t@Tensor{} = tMap (f x) t tMap2 f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2 -tDiag :: HasTensor a => Tensor a -> EgisonM (Tensor a)+tDiag :: HasTensor a => Tensor a -> EvalM (Tensor a) tDiag t@(Tensor _ _ js) = case filter (\j -> any (p j) js) js of [] -> return t@@ -298,7 +306,7 @@ p (Subscript _) _ = False p _ _ = False -tSum :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)+tSum :: HasTensor a => (a -> a -> EvalM a) -> Tensor a -> Tensor a -> EvalM (Tensor a) tSum f (Tensor ns1 xs1 js1) t2@Tensor{} = do t2' <- tTranspose js1 t2 case t2' of@@ -307,7 +315,7 @@ return (Tensor ns1 ys js1) | otherwise -> throwError =<< InconsistentTensorShape <$> getFuncNameStack -tProduct :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)+tProduct :: HasTensor a => (a -> a -> EvalM a) -> Tensor a -> Tensor a -> EvalM (Tensor a) tProduct f (Tensor ns1 xs1 js1') (Tensor ns2 xs2 js2') = do let k1 = fromIntegral $ length ns1 - length js1' let js1 = js1' ++ map (DFscript 0) [1..k1]@@ -353,7 +361,7 @@ return $ Tensor ns xs' js tProduct f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2 -tContract :: HasTensor a => Tensor a -> EgisonM [Tensor a]+tContract :: HasTensor a => Tensor a -> EvalM [Tensor a] tContract t = do t' <- tDiag t case t' of@@ -364,7 +372,7 @@ _ -> return [t'] -- TODO: refactor in PMOP-tContract' :: HasTensor a => Tensor a -> EgisonM (Tensor a)+tContract' :: HasTensor a => Tensor a -> EvalM (Tensor a) tContract' t@(Tensor ns _ js) = case findPair p js of Nothing -> return t@@ -382,14 +390,14 @@ p _ _ = False tContract' val = return val -tConcat :: HasTensor a => Index EgisonValue -> [Tensor a] -> EgisonM (Tensor a)+tConcat :: HasTensor a => Index EgisonValue -> [Tensor a] -> EvalM (Tensor a) tConcat s (Tensor ns@(0:_) _ js:_) = return $ Tensor (0:ns) V.empty (s:js) tConcat s ts@(Tensor ns _ js:_) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) (s:js) tConcat s ts = do ts' <- mapM getScalar ts return $ Tensor [fromIntegral (length ts)] (V.fromList ts') [s] -tConcat' :: HasTensor a => [Tensor a] -> EgisonM (Tensor a)+tConcat' :: HasTensor a => [Tensor a] -> EvalM (Tensor a) tConcat' (Tensor ns@(0:_) _ _ : _) = return $ Tensor (0:ns) V.empty [] tConcat' ts@(Tensor ns _ _ : _) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) [] tConcat' ts = do@@ -409,7 +417,7 @@ | otherwise = let (hs, ts) = V.splitAt (fromIntegral w) xs in hs:split w ts -getScalar :: Tensor a -> EgisonM a+getScalar :: Tensor a -> EvalM a getScalar (Scalar x) = return x getScalar _ = throwError $ Default "Inconsitent Tensor order"
hs-src/Tool/translator.hs view
@@ -9,6 +9,7 @@ import System.Environment (getArgs) import Language.Egison.AST+import Language.Egison.Parser (readUTF8File, removeShebang) import Language.Egison.Parser.SExpr import Language.Egison.Pretty @@ -34,7 +35,7 @@ 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)+ toNonS (PowerExpr x y) = InfixExpr powerOp (toNonS x) (toNonS y) where powerOp = fromJust $ find (\op -> repr op == "^") reservedExprInfix toNonS (InductiveDataExpr x ys) = InductiveDataExpr x (map toNonS ys) toNonS (TupleExpr xs) = TupleExpr (map toNonS xs)@@ -48,8 +49,8 @@ f [] = CollectionExpr [] f [ElementExpr x] = CollectionExpr [ElementExpr (toNonS x)] f [SubCollectionExpr x] = toNonS x- f (ElementExpr x : xs) = BinaryOpExpr cons (toNonS x) (f xs)- f (SubCollectionExpr x : xs) = BinaryOpExpr append (toNonS x) (f xs)+ f (ElementExpr x : xs) = InfixExpr cons (toNonS x) (f xs)+ f (SubCollectionExpr x : xs) = InfixExpr append (toNonS x) (f xs) cons = fromJust $ find (\op -> repr op == "::") reservedExprInfix append = fromJust $ find (\op -> repr op == "++") reservedExprInfix toNonS (HashExpr xs) = HashExpr (map (toNonS *** toNonS) xs)@@ -58,7 +59,6 @@ toNonS (LambdaExpr xs e) = LambdaExpr xs (toNonS e) toNonS (MemoizedLambdaExpr xs e) = MemoizedLambdaExpr xs (toNonS e) toNonS (CambdaExpr x e) = CambdaExpr x (toNonS e)- toNonS (ProcedureExpr xs e) = ProcedureExpr xs (toNonS e) toNonS (PatternFunctionExpr xs p) = PatternFunctionExpr xs (toNonS p) toNonS (IfExpr x y z) = IfExpr (toNonS x) (toNonS y) (toNonS z)@@ -80,16 +80,16 @@ toNonS (QuoteSymbolExpr x) = QuoteSymbolExpr (toNonS x) toNonS (WedgeApplyExpr (VarExpr f) (TupleExpr (y:ys))) | any (\op -> func op == prettyS f) reservedExprInfix =- optimize $ foldl (\acc x -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys+ optimize $ foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys where op = let op' = fromJust $ find (\op -> func op == prettyS f) reservedExprInfix in op' { isWedge = True } - optimize (BinaryOpExpr (Infix { repr = "*" }) (IntegerExpr (-1)) e2) =- UnaryOpExpr "-" (optimize e2)- optimize (BinaryOpExpr op e1 e2) =- BinaryOpExpr op (optimize e1) (optimize e2)+ optimize (InfixExpr (Infix { repr = "*" }) (IntegerExpr (-1)) e2) =+ PrefixExpr "-" (optimize e2)+ optimize (InfixExpr op e1 e2) =+ InfixExpr op (optimize e1) (optimize e2) optimize e = e toNonS (WedgeApplyExpr x y) = WedgeApplyExpr (toNonS x) (toNonS y) @@ -98,33 +98,33 @@ toNonS (SeqExpr e1 e2) = SeqExpr (toNonS e1) (toNonS e2) toNonS (ApplyExpr (VarExpr f) (TupleExpr (y:ys))) | prettyS f == "and" =- foldl (\acc x -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys+ foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys where op = fromJust $ find (\op -> repr op == "&&") reservedExprInfix toNonS (ApplyExpr (VarExpr f) (TupleExpr (y:ys))) | prettyS f == "or" =- foldl (\acc x -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys+ foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys where op = fromJust $ find (\op -> repr op == "||") reservedExprInfix toNonS (ApplyExpr (VarExpr f) (TupleExpr (y:ys))) | any (\op -> func op == prettyS f) reservedExprInfix =- optimize $ foldl (\acc x -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys+ optimize $ foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys where op = fromJust $ find (\op -> func op == prettyS f) reservedExprInfix - optimize (BinaryOpExpr (Infix { repr = "*" }) (IntegerExpr (-1)) e2) =- UnaryOpExpr "-" (optimize e2)- optimize (BinaryOpExpr op e1 e2) =- BinaryOpExpr op (optimize e1) (optimize e2)+ optimize (InfixExpr (Infix { repr = "*" }) (IntegerExpr (-1)) e2) =+ PrefixExpr "-" (optimize e2)+ optimize (InfixExpr op e1 e2) =+ InfixExpr op (optimize e1) (optimize e2) optimize e = e toNonS (ApplyExpr x y) = ApplyExpr (toNonS x) (toNonS y) toNonS (CApplyExpr e1 e2) = CApplyExpr (toNonS e1) (toNonS e2)- toNonS (PartialExpr n e) =- case PartialExpr n (toNonS e) of- PartialExpr 2 (BinaryOpExpr op (PartialVarExpr 1) (PartialVarExpr 2)) ->+ toNonS (AnonParamFuncExpr n e) =+ case AnonParamFuncExpr n (toNonS e) of+ AnonParamFuncExpr 2 (InfixExpr op (AnonParamExpr 1) (AnonParamExpr 2)) -> SectionExpr op Nothing Nothing -- TODO(momohatt): Check if %1 does not appear freely in e- -- PartialExpr 1 (BinaryOpExpr op e (PartialVarExpr 1)) ->+ -- AnonParamFuncExpr 1 (InfixExpr op e (AnonParamExpr 1)) -> -- SectionExpr op (Just (toNonS e)) Nothing- -- PartialExpr 1 (BinaryOpExpr op (PartialVarExpr 1) e) ->+ -- AnonParamFuncExpr 1 (InfixExpr op (AnonParamExpr 1) e) -> -- SectionExpr op Nothing (Just (toNonS e)) e' -> e' @@ -217,9 +217,9 @@ main :: IO () main = do args <- getArgs- input <- readFile $ head args+ input <- readUTF8File $ head args -- 'ast' is not desugared- let ast = parseTopExprs input+ let ast = parseTopExprs (removeShebang True input) case ast of Left err -> print err
lib/core/assoc.egi view
@@ -87,8 +87,8 @@ AC.intersect xs ys := matchAll (xs, ys) as (assocMultiset something, assocMultiset something) with- | (ncons $x $m _, ncons #x $n _) -> (x, min [m, n])+ | (ncons $x $m _, ncons #x $n _) -> (x, min m n) AC.intersectAs a xs ys := matchAll (xs, ys) as (assocMultiset a, assocMultiset a) with- | (ncons $x $m _, ncons #x $n _) -> (x, min [m, n])+ | (ncons $x $m _, ncons #x $n _) -> (x, min m n)
lib/core/io.egi view
@@ -7,62 +7,55 @@ -- -- IO ---print :=- procedure x ->- do write x- write "\n"- flush ()+print x :=+ do write x+ write "\n"+ flush () -printToPort :=- procedure port x ->- do writeToPort port x- writeToPort port "\n"+printToPort port x :=+ do writeToPort port x+ writeToPort port "\n" -display :=- procedure x ->- do write x- flush ()+display x :=+ do write x+ flush () -displayToPort := procedure port x -> do writeToPort port x+displayToPort port x := do writeToPort port x -eachLine :=- procedure proc ->- do let eof := isEof ()- if eof- then return ()- else do let line := readLine ()- proc line- eachLine proc+eachLine proc :=+ do let eof := isEof ()+ if eof+ then return ()+ else do let line := readLine ()+ proc line+ eachLine proc -eachLineFromPort :=- procedure port proc ->- do let eof := isEofPort port- if eof- then return ()- else do let line := readLineFromPort port- proc line- eachLineFromPort port proc+eachLineFromPort port proc :=+ do let eof := isEofPort port+ if eof+ then return ()+ else do let line := readLineFromPort port+ proc line+ eachLineFromPort port proc -eachFile :=- procedure files proc ->- match files as list string with- | [] -> return ()- | $file :: $rest ->- do let port := openInputFile file- eachLineFromPort port proc- closeInputPort port- eachFile rest proc+eachFile files proc :=+ match files as list string with+ | [] -> return ()+ | $file :: $rest ->+ do let port := openInputFile file+ eachLineFromPort port proc+ closeInputPort port+ eachFile rest proc -- -- Collection ---each :=- procedure proc xs ->- match xs as list something with- | [] -> do return ()- | $x :: $rs ->- do proc x- each proc rs+each proc xs :=+ match xs as list something with+ | [] -> do return ()+ | $x :: $rs ->+ do proc x+ each proc rs -- -- Debug
lib/core/random.egi view
@@ -45,12 +45,12 @@ R.head xs := head (matchAll xs as R.multiset something with- | $x :: $rs -> x)+ | $x :: _ -> x) R.tail xs := head (matchAll xs as R.multiset something with- | $x :: $rs -> rs)+ | _ :: $rs -> rs) sample := R.head
lib/math/common/functions.egi view
@@ -50,6 +50,10 @@ | #0 -> 0 | _ -> `tan x +acos := b.acos+asin := b.asin+atan := b.atan+ cosh $x := if isFloat x then b.cosh x@@ -70,6 +74,10 @@ else match x as mathExpr with | #0 -> 0 | _ -> `tanh x++acosh := b.acosh+asinh := b.asinh+atanh := b.atanh sinc $x := if isFloat x
lib/math/normalize.egi view
@@ -4,6 +4,7 @@ -- -- +--mathNormalize := id mathNormalize $x := if isInteger x then x
+ sample/ioRef.egi view
@@ -0,0 +1,11 @@+refTest x y :=+ do let w := newIORef ()+ writeIORef w x+ let w1 := readIORef w+ print (show w1)+ writeIORef w y+ let w2 := readIORef w+ print (show w2)+ flush ()++main args := refTest 1 2
sample/sat/cdcl.egi view
@@ -197,5 +197,5 @@ [2, 34, 30], [3, 16, 2], [-18, 45, -12], [33, 37, 10], [43, 7, -18], [-22, 44, -19], [-31, -27, -42], [-3, -40, 8], [-23, -31, 38]] -assertEqual "cdcl" (cdcl (between 1 20) problem20) True -- 2.798--- assertEqual "cdcl" (cdcl (between 1 50) problem50) False -- 1:10.74+--assertEqual "cdcl" (cdcl (between 1 20) problem20) True -- 2.798+assertEqual "cdcl" (cdcl (between 1 50) problem50) False -- 1:10.74
+ sample/tree.egi view
@@ -0,0 +1,41 @@+tree a := matcher+ | leaf $ as a with+ | Leaf $x -> [x]+ | Node _ _ -> []+ | node $ $ as (a, multiset (tree a)) with+ | Leaf _ -> []+ | Node $x $ts -> [(x, ts)]+ | $ :: $ as (a, tree a) with+ | Leaf _ -> []+ | Node $x $ts -> map (\t -> (x, t)) ts+ | $ ++ $ as (list a, tree a) with+ | $tgt -> matchAll tgt as tree a with+ | loop $i (1, $n) ($x_i :: ...) $t+ -> (map (\i -> x_i) [1..n], t)+ | $ as something with+ | $tgt -> [tgt]++treeData :=+ Node "Programming language"+ [Node "pattern-match-oriented" [Leaf "Egison"],+ Node "Functional language"+ [Node "Strictly typed" [Leaf "OCaml", Leaf "Haskell", Leaf "Curry", Leaf "Coq"],+ Node "Dynamically typed" [Leaf "Egison", Leaf "Lisp", Leaf "Scheme", Leaf "Racket"]],+ Node "Logic programming" [Leaf "Prolog", Leaf "Curry"],+ Node "Object oriented" [Leaf "C++", Leaf "Java", Leaf "Ruby", Leaf "Python", Leaf "OCaml"]]++ancestors x t :=+ matchAllDFS t as tree eq with+ | $hs ++ leaf #x -> hs++assertEqual "ancestors"+ (ancestors "Egison" treeData)+ [["Programming language", "pattern-match-oriented"], ["Programming language", "Functional language", "Dynamically typed"]]++descendants x t :=+ matchAllDFS t as tree eq with+ | _ ++ #x :: _ ++ leaf $y -> y++assertEqual "descendants"+ (descendants "Functional language" treeData)+ ["OCaml", "Haskell", "Curry", "Coq", "Egison", "Lisp", "Scheme", "Racket"]
test/Test.hs view
@@ -29,6 +29,7 @@ testCases = [ "test/syntax.egi" , "test/primitive.egi"+ , "test/lib/core/assoc.egi" , "test/lib/core/base.egi" , "test/lib/core/collection.egi" , "test/lib/core/maybe.egi"@@ -56,14 +57,14 @@ runTestCase :: FilePath -> Test runTestCase file = TestLabel file . TestCase $ do env <- initialEnv defaultOption- assertEgisonM $ do+ assertEvalM $ do exprs <- loadFile file let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs env' <- recursiveBind env bindings forM_ tests $ evalExprDeep env' where- assertEgisonM :: EgisonM a -> Assertion- assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")+ assertEvalM :: EvalM a -> Assertion+ assertEvalM m = fromEvalM m >>= assertString . either show (const "") collectDefsAndTests :: EgisonTopExpr -> ([(Var, EgisonExpr)], [EgisonExpr]) -> ([(Var, EgisonExpr)], [EgisonExpr]) collectDefsAndTests (Define name expr) (bindings, tests) =
+ test/lib/core/assoc.egi view
@@ -0,0 +1,73 @@+assertEqual "toAssoc"+ (toAssoc [x, x, y, z])+ [(x, 2), (y, 1), (z, 1)]++assertEqual "toAssoc"+ (toAssoc [x, y, x])+ [(x, 1), (y, 1), (x, 1)]++assertEqual "fromAssoc"+ (fromAssoc [(x, 2), (y, 1)])+ [x, x, y]++assertEqual "assocList"+ (matchAll [(x, 2), (y, 1)] as assocList something with+ | $a :: _ -> a)+ [x]++assertEqual "assocList"+ (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with+ | ncons $a #2 $r -> (a, r))+ [(x, [(x, 1), (y, 2), (z, 1)])]++assertEqual "assocList"+ (matchAll [(x, 1), (y, 2), (z, 3)] as assocList something with+ | ncons $a #2 $r -> (a, r))+ []++assertEqual "assocList"+ (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with+ | ncons $a $n $r -> (a, n, r))+ [(x, 3, [(y, 2), (z, 1)])]++assertEqual "assocList"+ (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with+ | ncons $a $n $r -> (a, n, r))+ [(x, 3, [(y, 2), (z, 1)])]++assertEqual "assocMultiset"+ (matchAll [(x, 2), (y, 1)] as assocMultiset something with+ | $a :: _ -> a)+ [x, y]++assertEqual "assocMultiset"+ (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with+ | ncons #z $n $r -> (n, r))+ [(1, [(x, 3), (y, 2)])]++assertEqual "assocMultiset"+ (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with+ | ncons $a #2 $r -> (a, r))+ [(x, [(x, 1), (y, 2), (z, 1)]), (y, [(x, 3), (z, 1)])]++assertEqual "assocMultiset"+ (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with+ | ncons #y #1 $r -> r)+ [[(x, 3), (y, 1), (z, 1)]]++assertEqual "assocMultiset"+ (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with+ | ncons $a $n $r -> (a, n, r))+ [(x, 3, [(y, 2), (z, 1)]), (y, 2, [(x, 3), (z, 1)]), (z, 1, [(x, 3), (y, 2)])]++assertEqual "AC.intersect"+ (AC.intersect [(x, 2), (y, 1)] [(x, 1), (y, 2)])+ [(x, 1), (y, 1)]++assertEqual "AC.intersect"+ (AC.intersect [(x, 2), (y, 2)] [(x, 1), (y, 1)])+ [(x, 1), (y, 1)]++assertEqual "AC.intersect"+ (AC.intersect [(x, 1), (y, 1)] [(x, 2), (y, 2)])+ [(x, 1), (y, 1)]
test/lib/core/base.egi view
@@ -55,6 +55,5 @@ -- assertEqual "unorderedPair matcher"- (match (1, 2) as unorderedPair integer with- | (#2, $x) -> x)+ (match (1, 2) as unorderedPair integer with (#2, $x) -> x) 1
test/lib/core/collection.egi view
@@ -196,9 +196,9 @@ assertEqual "drop" (drop 2 [1, 2, 3]) [3] -assertEqual "take-and-drop" (takeAndDrop 2 [1, 2, 3]) ([1, 2], [3])+assertEqual "takeAndDrop" (takeAndDrop 2 [1, 2, 3]) ([1, 2], [3]) -assertEqual "take-while" (takeWhile 1#(%1 < 10) primes) [2, 3, 5, 7]+assertEqual "takeWhile" (takeWhile (< 10) primes) [2, 3, 5, 7] assertEqual "head" (head [1, 2, 3]) 1 assertEqual "tail" (tail [1, 2, 3]) [2, 3]@@ -213,15 +213,11 @@ assertEqual "length" (length [1, 2, 3]) 3 -assertEqual "map" (map 1#(%1 * 2) [1, 2, 3]) [2, 4, 6]+assertEqual "map" (map (* 2) [1, 2, 3]) [2, 4, 6] assertEqual "map2" (map2 (*) [1, 2, 3] [10, 20, 30]) [10, 40, 90] -assertEqual- "filter"- (let isOdd n := modulo n 2 = 1- in filter isOdd [1, 2, 3])- [1, 3]+assertEqual "filter" (filter (\n -> n % 2 = 1) [1, 2, 3]) [1, 3] assertEqual "zip" (zip [1, 2, 3] [10, 20, 30]) [(1, 10), (2, 20), (3, 30)] @@ -231,36 +227,29 @@ assertEqual "foldl" (foldl (\ns n -> n :: ns) [] [1, 2, 3]) [3, 2, 1] -assertEqual "scanl" (scanl (\r n -> r * n) 2 [2, 2, 2]) [2, 4, 8, 16]--assertEqual "append" ([1, 2] ++ [3, 4, 5]) [1, 2, 3, 4, 5]+assertEqual "scanl" (scanl (*) 2 [2, 2, 2]) [2, 4, 8, 16] assertEqual "concat" (concat [[1, 2], [3, 4, 5]]) [1, 2, 3, 4, 5] assertEqual "reverse" (reverse [1, 2, 3]) [3, 2, 1] -assertEqual- "intersperse"+assertEqual "intersperse" (intersperse [0] [[1, 2], [3, 3], [4], []]) [[1, 2], [0], [3, 3], [0], [4], [0], []] -assertEqual- "intercalate"+assertEqual "intercalate" (intercalate [0] [[1, 2], [3, 3], [4], []]) [1, 2, 0, 3, 3, 0, 4, 0] -assertEqual- "split"+assertEqual "split" (split [0] [1, 2, 0, 3, 3, 0, 4, 0]) [[1, 2], [3, 3], [4], []] -assertEqual- "splitAs"+assertEqual "splitAs" (splitAs integer [0] [1, 2, 0, 3, 3, 0, 4, 0]) [[1, 2], [3, 3], [4], []] -assertEqual- "find-cycle"+assertEqual "findCycle" (findCycle [1, 3, 4, 5, 2, 7, 5, 2, 7, 5, 2, 7]) ([1, 3, 4], [5, 2, 7]) @@ -268,29 +257,29 @@ assertEqual "repeat1" (take 5 (repeat1 2)) [2, 2, 2, 2, 2] -assertEqual "all - case 1" (all 1#(%1 = 1) [1, 1, 1]) True+assertEqual "all" (all (= 1) [1, 1, 1]) True -assertEqual "all - case 2" (all 1#(%1 = 1) [1, 1, 2]) False+assertEqual "all" (all (= 1) [1, 1, 2]) False -assertEqual "any - case 1" (any 1#(%1 = 1) [0, 1, 0]) True+assertEqual "any" (any (= 1) [0, 1, 0]) True -assertEqual "any - case 2" (any 1#(%1 = 1) [0, 0, 0]) False+assertEqual "any" (any (= 1) [0, 0, 0]) False assertEqual "from" (take 3 (from 2)) [2, 3, 4] assertEqual "between" (between 2 5) [2, 3, 4, 5] -assertEqual "add - case 1" (add 1 [2, 3]) [2, 3, 1]+assertEqual "add" (add 1 [2, 3]) [2, 3, 1] -assertEqual "add - case 2" (add 1 [1, 2, 3]) [1, 2, 3]+assertEqual "add" (add 1 [1, 2, 3]) [1, 2, 3] -assertEqual "addAs - case 1" (addAs integer 1 [2, 3]) [2, 3, 1]+assertEqual "addAs" (addAs integer 1 [2, 3]) [2, 3, 1] -assertEqual "addAs - case 2" (addAs integer 1 [1, 2, 3]) [1, 2, 3]+assertEqual "addAs" (addAs integer 1 [1, 2, 3]) [1, 2, 3] -assertEqual "delete-first" (deleteFirst 2 [1, 2, 3, 2]) [1, 3, 2]+assertEqual "deleteFirst" (deleteFirst 2 [1, 2, 3, 2]) [1, 3, 2] -assertEqual "delete-firstAs" (deleteFirstAs integer 2 [1, 2, 3, 2]) [1, 3, 2]+assertEqual "deleteFirstAs" (deleteFirstAs integer 2 [1, 2, 3, 2]) [1, 3, 2] assertEqual "delete" (delete 2 [1, 2, 3, 1, 2, 3]) [1, 3, 1, 3] @@ -308,13 +297,13 @@ assertEqual "intersectAs" (intersectAs integer [1, 2, 3] [1, 3, 4]) [1, 3] -assertEqual "member - case 1" (member 1 [1, 3, 1, 4]) True+assertEqual "member" (member 1 [1, 3, 1, 4]) True -assertEqual "member - case 2" (member 2 [1, 3, 1, 4]) False+assertEqual "member" (member 2 [1, 3, 1, 4]) False -assertEqual "memberAs - case 1" (memberAs integer 1 [1, 3, 1, 4]) True+assertEqual "memberAs" (memberAs integer 1 [1, 3, 1, 4]) True -assertEqual "memberAs - case 2" (memberAs integer 2 [1, 3, 1, 4]) False+assertEqual "memberAs" (memberAs integer 2 [1, 3, 1, 4]) False assertEqual "count" (count 1 [1, 3, 1, 4]) 2 @@ -322,8 +311,7 @@ assertEqual "frequency" (frequency [1, 3, 1, 4]) [(1, 2), (3, 1), (4, 1)] -assertEqual- "frequencyAs"+assertEqual "frequencyAs" (frequencyAs integer [1, 3, 1, 4]) [(1, 2), (3, 1), (4, 1)]
test/lib/core/maybe.egi view
@@ -2,21 +2,14 @@ -- Maybe -- -assertEqual "nothing pattern and Just"+assertEqual "maybe" (matchAll Just 1 as maybe integer with+ | just $x -> x | nothing -> "error")- []--assertEqual "just pattern and Just"- (matchAll Just 1 as maybe integer with- | just $x -> x) [1] -assert "nothing pattern and Nothing"- (match Nothing as maybe integer with- | nothing -> True)--assertEqual "just pattern and Nothing"+assertEqual "maybe" (matchAll Nothing as maybe integer with- | just $x -> "error")- []+ | just _ -> "error"+ | nothing -> True)+ [True]
test/lib/core/number.egi view
@@ -2,24 +2,24 @@ -- Matcher -- -assertEqual "nat's o - case 1"+assertEqual "nat's o" (match 0 as nat with | o -> True | _ -> False) True -assertEqual "nat's o - case 2"+assertEqual "nat's o" (match 1 as nat with | o -> True | _ -> False) False -assertEqual "nat's s - case 1"+assertEqual "nat's s" (match 10 as nat with | s $n -> n) 9 -assertEqual "nat's s - case 2"+assertEqual "nat's s" (match 0 as nat with | s o -> True | _ -> False)@@ -45,29 +45,29 @@ assertEqual "divisor" (divisor 10 5) True -assertEqual "find-factor" (findFactor 100) 2--assertEqual "p-f" (pF 100) [2, 2, 5, 5]--assertEqual "isOdd - case 1" (isOdd 3) True--assertEqual "isOdd - case 2" (isOdd 4) False+assertEqual "findFactor" (findFactor 1) 1+assertEqual "findFactor" (findFactor 35) 5+assertEqual "findFactor" (findFactor 100) 2 -assertEqual "isEven - case 1" (isEven 4) True+assertEqual "pF" (pF 1) []+assertEqual "pF" (pF 3) [3]+assertEqual "pF" (pF 100) [2, 2, 5, 5] -assertEqual "isEven - case 2" (isEven 5) False+assertEqual "isOdd" (isOdd 3) True+assertEqual "isOdd" (isOdd 4) False -assertEqual "isPrime - case 1" (isPrime 17) True+assertEqual "isEven" (isEven 4) True+assertEqual "isEven" (isEven 5) False -assertEqual "isPrime - case 2" (isPrime 18) False+assertEqual "isPrime" (isPrime 17) True+assertEqual "isPrime" (isPrime 18) False assertEqual "perm" (perm 5 2) 20 assertEqual "comb" (comb 5 2) 10 -assertEqual "n-adic - case 1" (nAdic 10 123) [1, 2, 3]--assertEqual "n-adic - case 2" (nAdic 2 10) [1, 0, 1, 0]+assertEqual "nAdic" (nAdic 10 123) [1, 2, 3]+assertEqual "nAdic" (nAdic 2 10) [1, 0, 1, 0] assertEqual "rtod" (2#(%1, take 10 %2) (rtod (6 / 35)))@@ -75,9 +75,8 @@ assertEqual "rtod'" (rtod' (6 / 35)) (0, [1], [7, 1, 4, 2, 8, 5]) -assertEqual "show-decimal" (showDecimal 10 (6 / 35)) "0.1714285714"--assertEqual "show-decimal'" (showDecimal' (6 / 35)) "0.1 714285 ..."+assertEqual "showDecimal" (showDecimal 10 (6 / 35)) "0.1714285714"+assertEqual "showDecimal'" (showDecimal' (6 / 35)) "0.1 714285 ..." assertEqual "regular-continued-fraction sqrt of 2"@@ -106,12 +105,12 @@ 3.141592653589793 assertEqual- "regular-continued-fraction-of-sqrt case 1"+ "regularContinuedFractionOfSqrt case 1" (2#(%1, take 10 %2) (regularContinuedFractionOfSqrt 2)) (1, [2, 2, 2, 2, 2, 2, 2, 2, 2, 2]) assertEqual- "regular-continued-fraction-of-sqrt case 2"+ "regularContinuedFractionOfSqrt case 2" (rtof (regularContinuedFraction (2#(%1, take 100 %2) (regularContinuedFractionOfSqrt 2))))
test/lib/core/order.egi view
@@ -1,25 +1,33 @@-assertEqual "compare - case 1"+assertEqual "compare" (compare 10 10) Equal -assertEqual "compare - case 2"+assertEqual "compare" (compare 11 10) Greater -assertEqual "compare - case 3"+assertEqual "compare" (compare 10 11) Less assertEqual "min"- (minimum [20, 5])+ (min 20 5) 5 +assertEqual "minimum"+ (minimum [20, 5, 12])+ 5+ assertEqual "min/fn" (min/fn compare [10, 20, 5, 20, 30]) 5 assertEqual "max"- (maximum [5, 30])+ (max 5 30)+ 30++assertEqual "maximum"+ (maximum [5, 30, 23]) 30 assertEqual "max/fn"
test/lib/core/string.egi view
@@ -3,12 +3,12 @@ | #"abc" -> True | _ -> False) -assert "string's nil - case 1"+assert "string's nil" (match "" as string with | [] -> True | _ -> False) -assert "string's nil - case 2"+assert "string's nil" (match "abc" as string with | [] -> False | _ -> True)@@ -26,9 +26,9 @@ -- -- String as collection ---assertEqual "S.isEmpty - case 1" (S.isEmpty "") True+assertEqual "S.isEmpty" (S.isEmpty "") True -assertEqual "S.isEmpty - case 2" (S.isEmpty "Egison") False+assertEqual "S.isEmpty" (S.isEmpty "Egison") False assertEqual "S.head" (S.head "Egison") 'E'
test/primitive.egi view
@@ -52,28 +52,27 @@ assertEqual "sqrt" (sqrt 4) 2 assertEqual "sqrt" (sqrt 4.0) 2.0--- assertEqual "sqrt" (sqrt (-1)) i+assertEqual "sqrt" (sqrt (-1)) i --- assertEqual "exp"--- [exp 1, exp 1.0, exp (-1.0)]--- [e, 2.718281828459045, 0.36787944117144233]+assertEqual "exp" (exp 1) e+assertEqual "exp" (exp 1.0) 2.718281828459045+assertEqual "exp" (exp (-1.0)) 0.36787944117144233 --- assertEqual "log"--- [log e, log 10.0]--- [1, 2.302585092994046]+assertEqual "log" (log e) 1+assertEqual "log" (log 10.0) 2.302585092994046 --- TODO: trigonometric functions--- * sin--- * cos--- * tan--- * asin--- * acos--- * sinh--- * cosh--- * tanh--- * asinh--- * acosh--- * atanh+assertEqual "sin" (sin 0.0) 0.0+assertEqual "cos" (cos 0.0) 1.0+assertEqual "tan" (tan 0.0) 0.0+assertEqual "asin" (asin 0.0) 0.0+assertEqual "acos" (acos 1.0) 0.0+assertEqual "atan" (atan 0.0) 0.0+assertEqual "sinh" (sinh 0.0) 0.0+assertEqual "cosh" (cosh 0.0) 1.0+assertEqual "tanh" (tanh 0.0) 0.0+assertEqual "asinh" (asinh 0.0) 0.0+assertEqual "acosh" (acosh 1.0) 0.0+assertEqual "atanh" (atanh 0.0) 0.0 -- tensorSize -- tensorToList@@ -157,7 +156,6 @@ assertEqual "isHash" (isHash {| |}) True assertEqual "isHash" (isHash {| (1, 2) |}) True --- TODO: Add a test case where isTensor returns True assertEqual "isTensor" (isTensor 1) False assertEqual "isTensor" (isTensor [| 1 |]) True assertEqual "isTensor" (isTensor (generateTensor (+) [1, 2])) True
test/syntax.egi view
@@ -207,6 +207,17 @@ (capply (+) [1, 2]) 3 +f0 () := 1+f2 (x, y) := x + y++assertEqual "nullary function definition"+ (f0 ())+ 1++assertEqual "function definition with tupled argument"+ (f2 1 2)+ 3+ {- This is a comment -}