diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2017 aiya000 + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Maru.Main + +main :: IO () +main = runRepl >> putStrLn "Bye" diff --git a/src/Maru/Eval.hs b/src/Maru/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Eval.hs @@ -0,0 +1,451 @@ +-- Suppress warnings what is happend by TemplateHaskell +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +--TODO: Organize document comments + +-- | @MaruEvaluator@ evaluates @SEexpr@. +module Maru.Eval + ( initialEnv + , eval + ) where + +import Control.Exception.Safe (Exception, SomeException, toException) +import Control.Exception.Throwable.TH (declareException) +import Control.Lens ((^?)) +import Control.Monad (when) +import Control.Monad.Fail (fail) +import Data.Extensible (castEff) +import Data.Function ((&)) +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Maru.Type +import Prelude hiding (fail) +import TextShow (showt) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Maru.Eval.RuntimeOperation as OP +import qualified Maru.Type.SExpr as MSym (pack) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :set -XOverloadedLists +-- >>> import Control.Lens (_Just) +-- >>> import qualified Maru.Eval.RuntimeOperation as OP +-- >>> import qualified Maru.Type.Eval as TE +-- >>> let runMaruEvaluatorDefault = flip runMaruEvaluator initialEnv +-- >>> :{ +-- >>> let modifiedEnv = initialEnv <> +-- [[ ("*x*", AtomInt 10) +-- , ("*y*", AtomSymbol "*x*") +-- ]] +-- >>> :} + +declareException "EvalException" ["EvalException"] + + +--TODO: AtomSymbol is not the string literal ! +-- | +-- An initial value of the runtime. +-- This is the empty. +initialEnv :: MaruEnv +initialEnv = [[ ("nil", Nil) + , ("def!", AtomSymbol "#core-macro") + , ("let*", AtomSymbol "#core-macro") + , ("do", AtomSymbol "#core-macro") + , ("if", AtomSymbol "#core-macro") + , ("fn*", AtomSymbol "#core-macro") + , ("print", AtomSymbol "#core-macro") + , ("list", AtomSymbol "#core-macro") + ]] + + +-- | +-- Make the failure context with the message, +-- like "funcName: an invalid condition is detected `{invalidTerm}`" +-- ('return with the invalid term') +returnInvalid :: Text -> SExpr -> MaruEvaluator a +returnInvalid funcName invalidTerm = throwFail $ funcName <> ": an invalid condition is detected `" <> showt invalidTerm <> "`" + + +-- | +-- Evaluate a S expression, +-- and happen its side effects. +-- +-- If you don't have a value of @MaruEnv@, you can use @initialEnv@. +-- +-- Return an evaluated result, with new @MaruEnv@ +-- (@env@ is changed if the evaluation of @SExpr@ changes @MaruEnv@). +eval :: MaruEnv -> SExpr -> IO (Either SomeException (SExpr, MaruEnv, SimplificationSteps)) +eval env sexpr = do + (result, newEnv, simplifLogs) <- runMaruEvaluator (execute sexpr) env + case result of + Left cause -> return . Left . toException $ EvalException (T.unpack cause) sexpr + Right sexpr -> return $ Right (sexpr, newEnv, simplifLogs) + + +-- | +-- >>> flatten Nil -- () +-- [] +-- >>> flatten $ AtomInt 10 -- 10 +-- [AtomInt 10] +-- >>> flatten $ Cons (AtomInt 1) (Cons (AtomInt 2) (Cons (AtomInt 3) Nil)) -- (1 2 3) +-- [AtomInt 1,AtomInt 2,AtomInt 3] +-- >>> flatten $ Cons (AtomInt 2) (Cons (Cons (AtomInt 3) (Cons (AtomInt 4) (Cons (AtomInt 5) Nil))) Nil) -- (2 (3 4 5)) +-- [AtomInt 2,Cons (AtomInt 3) (Cons (AtomInt 4) (Cons (AtomInt 5) Nil))] +-- >>> flatten $ Cons (Cons (AtomInt 1) (Cons (AtomInt 2) Nil)) (Cons (Cons (AtomInt 3) (Cons (AtomInt 4) Nil)) Nil) -- ((1 2) (3 4)) +-- [Cons (AtomInt 1) (Cons (AtomInt 2) Nil),Cons (AtomInt 3) (Cons (AtomInt 4) Nil)] +flatten :: SExpr -> [SExpr] +flatten Nil = [] +flatten (AtomInt x) = [AtomInt x] +flatten (AtomBool x) = [AtomBool x] +flatten (AtomSymbol x) = [AtomSymbol x] +flatten (Cons x y) = [x] ++ flatten y +flatten (Quote x) = [Quote x] + + +-- | +-- A naked evaluator of zuramaru +-- +-- Evaluate a macro, +-- or Calculate a function +execute :: SExpr -> MaruEvaluator SExpr +-- def! and let* is the axioms +execute (Cons (AtomSymbol "def!") s) = execMacro defBang s +execute (Cons (AtomSymbol "let*") s) = execMacro letStar s +execute (Cons (AtomSymbol "do") s) = execMacro do_ s +execute (Cons (AtomSymbol "if") s) = execMacro if_ s +-- the forms of '((fn* xxx yyy) z)' are applied as a function +execute (Cons (Cons (AtomSymbol "fn*") (Cons params (Cons body Nil))) args) = execMacro funcall $ Cons params (Cons body (Cons args Nil)) +-- the forms of '(fn* xxx yyy)' of '(let* (f (fn* xxx yyy)))' are evaluated +execute (Cons (AtomSymbol "fn*") s) = execMacro binding s +-- `hi-maru-env` for debug +execute (Cons (AtomSymbol "hi-maru-env") Nil) = execMacro hiMaruEnv Nil +execute (Cons (AtomSymbol "print") s) = execMacro print_ s +execute (Cons (AtomSymbol "list") s) = execMacro list s +execute sexpr = execMacro call sexpr + + +-- | +-- let* +-- +-- (let* (x 10) x) +-- +-- >>> (result, env, _) <- runMaruEvaluatorDefault $ execMacro letStar (Cons (Cons (AtomSymbol "x") (Cons (AtomInt 10) Nil)) (Cons (AtomSymbol "x") Nil)) +-- >>> result +-- Right (AtomInt 10) +-- >>> TE.lookup "x" env +-- Nothing +letStar :: MaruMacro +letStar = MaruMacro $ \case + Cons (Cons (AtomSymbol sym) (Cons x Nil)) (Cons body Nil) -> do + newScope sym x + result <- execute body + popNewerScope + return result + s -> fail $ "let*: an invalid condition is detected `" ++ show s ++ "`" + + +-- | +-- Call general function/macro (other than def!/let*). +-- If it has a head element, apply tail elements to the head element. (+ 1 2) +-- +-- If it is a symbol, find the symbol from current environment (`MaruEnv`) +-- (Throw exception if it couldn't be found). +-- +-- If it is an another primitive value, return just it. +-- +-- (+ 1 2) +-- +-- >>> (result, _, _) <- runMaruEvaluatorDefault $ execMacro call (Cons (AtomSymbol "+") (Cons (AtomInt 1) (Cons (AtomInt 2) Nil))) +-- >>> let expected = runMaruCalculator $ execFunc OP.add [AtomInt 1, AtomInt 2] +-- >>> result == expected +-- True +-- +-- *x* +-- +-- >>> (result, _, _) <- flip runMaruEvaluator modifiedEnv $ execMacro call (AtomSymbol "*x*") +-- >>> result +-- Right (AtomInt 10) +-- +-- *y* +-- +-- >>> (result', _, _) <- flip runMaruEvaluator modifiedEnv $ execMacro call (AtomSymbol "*y*") +-- >>> result' == result +-- True +-- +-- the quote +-- +-- >>> (of10, _, _) <- flip runMaruEvaluator modifiedEnv $ execMacro call (Quote (AtomInt 10)) +-- >>> of10 +-- Right (AtomInt 10) +-- +-- >>> (ofSym, _, _) <- flip runMaruEvaluator modifiedEnv $ execMacro call (Quote (AtomSymbol "some---symbol")) +-- >>> ofSym +-- Right (AtomSymbol "some---symbol") +call :: MaruMacro +-- Extract a value +call = MaruMacro call' + where + call' :: SExpr -> MaruEvaluator SExpr + call' (AtomInt x) = return $ AtomInt x + call' (AtomBool x) = return $ AtomBool x + call' Nil = return Nil + call' (Quote x) = return x + + -- Look up the value from the current environment + call' (AtomSymbol sym) = + lookupVar sym >>= \case + AtomSymbol s -> call' $ AtomSymbol s + --TODO: Currently, sym is regarded to the string value. Because the string literal is not implemented at now. Don't regard to the string value, throw the exception with the cause of "the symbol is not found". + x -> return x + + call' (Cons Nil Nil) = return Nil -- `()` is evaluted to `()` + + -- The axiomly functions + call' (Cons (AtomSymbol "+") args) = mapM execute (flatten args) >>= castEff . execFunc OP.add + call' (Cons (AtomSymbol "-") args) = mapM execute (flatten args) >>= castEff . execFunc OP.sub + call' (Cons (AtomSymbol "*") args) = mapM execute (flatten args) >>= castEff . execFunc OP.times + call' (Cons (AtomSymbol "/") args) = mapM execute (flatten args) >>= castEff . execFunc OP.div + -- + call' (Cons (AtomSymbol sym) args) = do + val <- lookupVar sym + execute $ Cons val args + + call' s@(Cons x _) = throwFail $ "expected the symbol of the function or the macro, but got `" <> showt x <> "` (in `" <> showt s <> "`)" + + +-- | +-- def! +-- +-- (def! *x* 10) +-- +-- >>> (result, envWithX, _) <- runMaruEvaluatorDefault $ execMacro defBang (Cons (AtomSymbol "*x*") (Cons (AtomInt 10) Nil)) +-- >>> result +-- Right (AtomInt 10) +-- >>> TE.lookup "*x*" envWithX ^? _Just +-- Just (AtomInt 10) +-- +-- Define "*y*" over "*x*" +-- (def! *y* *x*) +-- +-- >>> (result, env, _) <- flip runMaruEvaluator envWithX $ execMacro defBang (Cons (AtomSymbol "*y*") (Cons (AtomSymbol "*x*") Nil)) +-- >>> result +-- Right (AtomInt 10) +-- >>> TE.lookup "*y*" env ^? _Just +-- Just (AtomInt 10) +-- +-- Define "*z*" over a calculation (+ 1 2) +-- +-- >>> (result, env, _) <- runMaruEvaluatorDefault $ execMacro defBang (Cons (AtomSymbol "*z*") (Cons (Cons (AtomSymbol "+") (Cons (AtomInt 1) (Cons (AtomInt 2) Nil))) Nil)) +-- >>> result +-- Right (AtomInt 3) +-- >>> TE.lookup "*z*" env ^? _Just +-- Just (AtomInt 3) +defBang :: MaruMacro +defBang = MaruMacro $ \case + Cons (AtomSymbol sym) (Cons val Nil) -> do + val' <- execute val + insertGlobalVar sym val' + return val' + s -> returnInvalid "def!" s + + +-- | +-- 'do' macro evaluates all the taken arguments sequentially. +-- +-- ` +-- (do +-- (def! x 10) +-- (def! y (+ x 1)) +-- (def! z (+ y 1))) +-- ` +-- returns 12. +-- +-- >>> let sexpr = Cons (Cons (AtomSymbol "def!") (Cons (AtomSymbol "x") (Cons (AtomInt 10) Nil))) (Cons (Cons (AtomSymbol "def!") (Cons (AtomSymbol "y") (Cons (Cons (AtomSymbol "+") (Cons (AtomSymbol "x") (Cons (AtomInt 1) Nil))) Nil))) (Cons (Cons (AtomSymbol "def!") (Cons (AtomSymbol "z") (Cons (Cons (AtomSymbol "+") (Cons (AtomSymbol "y") (Cons (AtomInt 1) Nil))) Nil))) Nil)) +-- >>> (result, _, _) <- runMaruEvaluatorDefault $ execMacro do_ sexpr +-- >>> result +-- Right (AtomInt 12) +do_ :: MaruMacro +do_ = MaruMacro $ \case + -- The calculation for `()` is not needed + Cons Nil Nil -> return Nil + -- Don't evaluate `(x)` to `x` + s@(Cons _ Nil) -> returnInvalid "do" s + sexpr -> do + let evaluatees = flatten sexpr + xs <- mapM execute evaluatees + if null xs + then throwFail "do: fatal error !!" -- This case is already avoided by the above `Cons Nil Nil` pattern + else return $ last xs + + +-- | +-- 'if' macro branches to the arguments by the condition. +-- +-- `(if true 10 20)` returns 10. +-- +-- `(if false 10 20)` returns 20. +-- +-- otherwise, the exception is thrown. +if_ :: MaruMacro +if_ = MaruMacro $ \case + Cons cond (Cons x (Cons y Nil)) -> do + cond' <- execute cond + case cond' of + AtomBool False -> execute y + Nil -> execute y + _ -> execute x + s -> returnInvalid "if" s + + +-- ` +-- (def! x 10) +-- (fn* (a) x) +-- ` +-- makes +-- `(fn* (a) 10)` +-- +-- +-- the expansion is recursively, +-- but only the symbol of +, -, *, / are not expanded. +-- ` +-- (def! z 1) +-- (def! y (- 1 z) +-- (def! x (+ y z)) +-- (fn* (a) x) +-- ` +-- makes +-- `(fn* (a) (+ (- 1 1) 1))` +--TODO: ^^^ Think about this behavior and Add this to below (funcall's) doc comment if it is correct + +-- | +-- Make a temporary function (it is often called 'lambda function'). +-- +-- fn* macro is made up by this and `funcall` macro. +-- +-- This is the caller, 'binding' is the callee. +-- +-- Expand a S expression of its body (Make a closure expression). +-- +-- If the conversion of S expression can be executed in any time (or if the completely immutability is promised), +-- this expansion can be the one of strategy in the real for the binding variables of the closure. +-- +-- >>> :{ +-- do +-- let modifiedEnv = initialEnv <> +-- [[ ("z", AtomInt 1) +-- , ("y", Cons (AtomSymbol "-") (Cons (AtomInt 1) (Cons (AtomSymbol "z") Nil))) +-- , ("x", Cons (AtomSymbol "+") (Cons (AtomSymbol "y") (Cons (AtomSymbol "z") Nil))) +-- ]] +-- let sexpr = Cons (Cons (AtomSymbol "a") Nil) (Cons (AtomSymbol "x") Nil) +-- (result, _, _) <- flip runMaruEvaluator modifiedEnv $ execMacro binding sexpr +-- return result +-- :} +-- Right (Cons (AtomSymbol "fn*") (Cons (Cons (AtomSymbol "a") Nil) (Cons (Cons (AtomSymbol "+") (Cons (Cons (AtomSymbol "-") (Cons (AtomInt 1) (Cons (AtomInt 1) Nil))) (Cons (AtomInt 1) Nil))) Nil))) +binding :: MaruMacro +binding = MaruMacro $ \case + Cons params body -> do + let cause = "fn* (caller): the function's formal parameter must be the symbol, but another things are specified: `" <> showt params <> "`" + params' <- includeFail cause . return $ flatten params ^? asSymbolList + expandedBody <- expandVarsWihtoutParams params' body + return $ Cons (AtomSymbol "fn*") (Cons params expandedBody) + s -> returnInvalid "fn* (caller)" s + where + -- Similar to 'expandVars', + -- but if the 'MaruSymbol' is included in taken ['MaruSymbol'], + -- it is not expanded + expandVarsWihtoutParams :: [MaruSymbol] -> SExpr -> MaruEvaluator SExpr + expandVarsWihtoutParams _ (AtomSymbol "+") = return $ AtomSymbol "+" + expandVarsWihtoutParams _ (AtomSymbol "-") = return $ AtomSymbol "-" + expandVarsWihtoutParams _ (AtomSymbol "*") = return $ AtomSymbol "*" + expandVarsWihtoutParams _ (AtomSymbol "/") = return $ AtomSymbol "/" + expandVarsWihtoutParams _ Nil = return Nil + expandVarsWihtoutParams _ (AtomInt x) = return $ AtomInt x + expandVarsWihtoutParams _ (AtomBool x) = return $ AtomBool x + expandVarsWihtoutParams _ (Quote x) = return $ Quote x + expandVarsWihtoutParams params' (Cons x y) = Cons <$> expandVarsWihtoutParams params' x <*> expandVarsWihtoutParams params' y + expandVarsWihtoutParams params' (AtomSymbol var) = + if var `elem` params' then return $ AtomSymbol var + else lookupVar var >>= expandVarsWihtoutParams params' + + +--NOTE: 'params' means dummy arguments, 'args' means real arguments +-- | +-- Apply 'args' to 'params' with 'body' as a function body. +-- +-- fn* macro is made up by this and `binding` macro. +-- +-- `((fn* (x y) (+ x y)) 1 2)` +-- +-- >>> let args = Cons (AtomInt 1) (Cons (AtomInt 2) Nil) +-- >>> let params = Cons (AtomSymbol "x") (Cons (AtomSymbol "y") Nil) +-- >>> let body = Cons (AtomSymbol "+") (Cons (AtomSymbol "x") (Cons (AtomSymbol "y") Nil)) +-- >>> (result, _, _) <- runMaruEvaluatorDefault $ execMacro funcall (Cons params (Cons body (Cons args Nil))) +-- >>> result +-- Right (AtomInt 3) +funcall :: MaruMacro +funcall = MaruMacro $ \s -> case flatten s of + [params, body, args] -> do + let cause = "fn* (callee): the function's formal parameter must be the symbol, but another things are specified: `" <> showt params <> "`" + mappee <- includeFail cause . return $ flatten params ^? asSymbolList + mapper <- mapM execute $ flatten args + when (length mappee /= length mapper) . + throwFail $ "fn* (callee): the dummy params and the real args are different length: params `" <> showt mappee <> "`, args `" <> showt mapper <> "`" + let mapping = map (uncurry substituteVar) $ zip mappee mapper + execute $ foldl' (&) body mapping + _ -> returnInvalid "fn* (callee)" s + + +-- | +-- For debug. +-- Take out 'MaruEnv' of 'MaruScopes' as the list of cons. +hiMaruEnv :: MaruMacro +hiMaruEnv = MaruMacro $ \_ -> + --TODO: AtomSymbol is not the string literal !! Implement string literal + AtomSymbol . MSym.pack . show <$> getMaruEnv + + +-- | Print nothing or a S expression on the screen +print_ :: MaruMacro +print_ = MaruMacro $ nilOf . \case + Nil -> liftIOEff $ putStr "" + sexpr@(Cons _ _) -> do + sexprs <- mapM ((readable <$>) . execute) $ flatten sexpr + liftIOEff $ case nonEmpty sexprs of + Nothing -> putStr "" + Just (x:|xs) -> T.putStr $ foldl' (<<>>) x xs + x -> returnInvalid "print" x + where + nilOf :: MaruEvaluator a -> MaruEvaluator SExpr + nilOf x = x >> return Nil + + (<<>>) :: Text -> Text -> Text + x <<>> y = x <> "\n" <> y + + +-- | Make a list with arguments +list :: MaruMacro +list = MaruMacro $ fmap scottEncode . mapM execute . flatten + + +-- | +-- Be called recursively in a recursive function +-- +-- (Cons (Cons (AtomSymbol "fn") (Cons (Cons (AtomSymbol "a") Nil) (Cons (Cons (Cons (AtomSymbol "fn") (Cons (Cons (AtomSymbol "x") Nil) (Cons (Cons (AtomSymbol "if") (Cons (Cons (AtomSymbol "<=") (Cons (AtomInt 0) (Cons (AtomSymbol "x") Nil))) (Cons (AtomInt 0) (Cons (Cons (AtomSymbol "this") (Cons (Cons (AtomSymbol "-") (Cons (AtomSymbol "x") (Cons (AtomInt 1) Nil))) Nil)) Nil)))) Nil))) (Cons (Cons (AtomSymbol "-") (Cons (AtomSymbol "a") (Cons (AtomInt 1) Nil))) Nil)) Nil))) (Cons (AtomInt 5) Nil)) +--this :: MaruMacro +--this = MaruMacro $ \case +-- Nil -> diff --git a/src/Maru/Eval/RuntimeOperation.hs b/src/Maru/Eval/RuntimeOperation.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Eval/RuntimeOperation.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +--TODO: Introduce LiquidHaskell + +-- | +-- Define functions and macros, these are used in the runtime, +-- +-- also these are through with `MaruEnv` (it should be `Maru.Eval.initialEnv`) +-- +-- These respects clisp's behavior basically. +-- +-- `add`, `sub`, `times`, and `div` are regarded as axiomly functions. +module Maru.Eval.RuntimeOperation + ( add + , sub + , times + , div + ) where + +import Control.Lens hiding (set) +import Control.Monad.Fail (fail) +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (maybeToList) +import Data.Semigroup ((<>)) +import Maru.Type +import Numeric.Extra (intToDouble) +import Prelude hiding (div, fail) +import TextShow (showt) +import qualified Data.List.NonEmpty as NE +import qualified Maru.Type as MT + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens hiding (set) +-- >>> import Data.Either +-- >>> import Maru.Eval +-- >>> import Maru.Type +-- >>> import qualified Data.Map.Lazy as M + + +ignoreAtomInt :: [SExpr] -> [SExpr] +ignoreAtomInt xs = xs ^.. folded . filtered (not . MT.isAtomInt) + + +-- | +-- Find all `AtomInt` elements, +-- Calculate its summation, +-- and wrap by `AtomInt`. +-- +-- Return `AtomInt 0` if the given list is empty. +sumOfAtomInt :: [SExpr] -> SExpr +sumOfAtomInt = (AtomInt .) . sumOf $ folded . MT._AtomInt + + +-- | +-- >>> runMaruCalculator $ execFunc add [AtomInt 1, AtomInt 2] +-- Right (AtomInt 3) +-- >>> runMaruCalculator $ execFunc add [] +-- Right (AtomInt 0) +-- >>> isLeft . runMaruCalculator $ execFunc add [AtomSymbol "xD"] +-- True +add :: MaruFunc +add = MaruFunc $ \xs -> case ignoreAtomInt xs of + [] -> return $ sumOfAtomInt xs + invalidArgs -> fail $ "add: invalid arguments are given to (+): " ++ show invalidArgs + + +-- | +-- >>> runMaruCalculator $ execFunc sub [AtomInt 3, AtomInt 1] +-- Right (AtomInt 2) +-- >>> runMaruCalculator $ execFunc sub [AtomInt 1] +-- Right (AtomInt (-1)) +-- >>> isLeft . runMaruCalculator $ execFunc sub [] +-- True +-- >>> isLeft . runMaruCalculator $ execFunc sub [AtomSymbol "xD"] +-- True +sub :: MaruFunc +sub = MaruFunc $ \case + [] -> fail "sub: takes a list of integer values, but took list is empty" + w@(x:xs) -> case ignoreAtomInt w of + [] -> do + let cause = "sub: fatal error! with `" <> showt w <> "`" + let result = negativeSumOfAtomInt (x:|xs) + includeFail cause $ return result + invalidArgs -> fail $ "sub: invalid arguments are given to (-): " ++ show invalidArgs + where + -- head - tail + {-@ negativeSumOfAtomInt :: {(x:|xs):NonEmpty SExpr | null $ ignoreAtomInt (x:xs) } -> SExpr @-} + negativeSumOfAtomInt :: NonEmpty SExpr -> Maybe SExpr + negativeSumOfAtomInt (AtomInt x:|[]) = Just $ AtomInt (-x) + negativeSumOfAtomInt (x:|xs) = foldl' subSExpr (Just x) xs + + subSExpr :: Maybe SExpr -> SExpr -> Maybe SExpr + subSExpr Nothing _ = Nothing + subSExpr (Just (AtomInt x)) (AtomInt y) = Just . AtomInt $ x - y + subSExpr _ _ = Nothing + + +-- | +-- >>> runMaruCalculator $ execFunc times [AtomInt 3, AtomInt 3] +-- Right (AtomInt 9) +-- >>> runMaruCalculator $ execFunc times [] +-- Right (AtomInt 1) +-- >>> isLeft . runMaruCalculator $ execFunc times [AtomSymbol "xD"] +-- True +times :: MaruFunc +times = MaruFunc $ \xs -> case ignoreAtomInt xs of + [] -> return . AtomInt $ productOf (folded . MT._AtomInt) xs + invalidArgs -> fail $ "times: invalid arguments are given to (*): " ++ show invalidArgs + + +--TODO: This makes an integral number unless like AtomRatio is implemented to SExpr +-- | +-- >>> runMaruCalculator $ execFunc div [AtomInt 3, AtomInt 3] +-- Right (AtomInt 1) +-- >>> isLeft . runMaruCalculator $ execFunc div [] +-- True +-- >>> isLeft . runMaruCalculator $ execFunc div [AtomSymbol "xD"] +-- True +-- >>> isLeft . runMaruCalculator $ execFunc div [AtomInt 0, AtomInt 1] +-- True +-- >>> runMaruCalculator $ execFunc div [AtomInt 10, AtomInt 3] +-- Right (AtomInt 3) +-- >>> runMaruCalculator $ execFunc div [AtomInt 3, AtomInt 5] +-- Right (AtomInt 0) +div :: MaruFunc +div = MaruFunc $ \case + [] -> fail "div: takes a non empty list, but took list is empty" + w@(x:xs) -> case (ignoreAtomInt w, negativeProductOfAtomInt (x:|xs)) of + ([], Nothing) -> fail "div: 0 is divided by anything" + ([], Just z) -> return z + (invalidArgs, _) -> fail $ "div: invalid arguments are given to (/): " ++ show invalidArgs + where + -- Safe (/) + (/?) :: Maybe Double -> Double -> Maybe Double + Nothing /? _ = Nothing + Just 0 /? _ = Nothing + Just x /? y = Just $ x / y + -- Extract [`Int`] from [`AtomInt`], + -- and Convert each `Int` to `Double` + doublesFromAtomInt :: NonEmpty SExpr -> [Double] + doublesFromAtomInt = concatMap (maybeToList . (intToDouble <$>) . MT.unAtomInt) . NE.filter MT.isAtomInt + -- All `NonEmpty SExpr` element are `AtomInt`. + -- If 0 was devided, return `Nothing`. + negativeProductOfAtomInt :: NonEmpty SExpr -> Maybe SExpr + negativeProductOfAtomInt (doublesFromAtomInt -> (x:xs)) + = AtomInt . truncate <$> foldl' (/?) (Just x) xs + negativeProductOfAtomInt _ + = Nothing diff --git a/src/Maru/Main.hs b/src/Maru/Main.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Main.hs @@ -0,0 +1,234 @@ +-- Suppress warnings what is happend by TemplateHaskell +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Maru.Main + ( runRepl + ) where + +import Control.Exception.Safe (SomeException) +import Control.Lens (view, (%=), (<>=), (.=), Iso', iso) +import Control.Monad (mapM, when, void, forM_) +import Control.Monad.State.Class (MonadState(..), gets) +import Data.Data (Data) +import Data.Extensible +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Maru.Preprocessor (preprocess) +import Maru.TH (makeLensesA) +import Maru.Type +import Safe (tailMay) +import System.Console.CmdArgs (cmdArgs, summary, program, help, name, explicit, (&=)) +import TextShow (showt) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Maru.Eval as E +import qualified Maru.Parser as Parser +import qualified Maru.Type as MT +import qualified System.Console.Readline as R + +-- | Command line options +data CliOptions = CliOptions + { debugMode :: Bool + , doEval :: Bool + } deriving (Show, Data, Typeable) + +makeLensesA ''CliOptions + +-- | Default of `CliOptions` +cliOptions :: CliOptions +cliOptions = CliOptions + { debugMode = False &= name "debug" + , doEval = True &= name "do-eval" + &= help "If you don't want to evaluation, disable this" + &= explicit + } + &= summary "マルのLisp処理系ずら〜〜" + &= program "maru" + + +-- | +-- Logs of REPL. +-- +-- This is collected in 'Read' and 'Eval' phase of REPL, +-- and this is shown in 'Print' phase of REPL. +-- +-- This is not shown if you doesn't specifiy --debug. +data DebugLogs = DebugLogs + { readLogs :: [Text] + , evalLogs :: [Text] + } deriving (Show) + +makeLensesA ''DebugLogs + +-- | An empty value of `DebugLogs` +emptyDebugLog :: DebugLogs +emptyDebugLog = DebugLogs [] [] + + +-- | Integrate any type as @State@ of REPL. +data ReplState = ReplState + { replOpts :: CliOptions -- ^ specified CLI options (not an initial value) + , replEnv :: MaruEnv -- ^ The symbols of zuramaru + , replLogs :: DebugLogs -- ^ this value is appended in the runtime + } + +makeLensesA ''ReplState + + +-- | For Lens Accessors +instance Associate "stateRepl" (State ReplState) xs => MonadState ReplState (Eff xs) where + get = getEff #stateRepl + put = putEff #stateRepl + + +-- | +-- The eval phase do parse and evaluation, +-- take its error or a rightly result +data EvalPhaseResult = ParseError ParseErrorResult -- ^ An error is happened in the parse + | EvalError SomeException -- ^ An error is happend in the evaluation + | RightResult SExpr -- ^ A result is made by the parse and the evaulation without errors + +type Evaluator = MaruEnv -> SExpr -> IO (Either SomeException (SExpr, MaruEnv, SimplificationSteps)) + + +-- | Run REPL of zuramaru +runRepl :: IO () +runRepl = do + options <- cmdArgs cliOptions + let initialState = ReplState options E.initialEnv emptyDebugLog + void . retractEff @ IOEffKey $ runStateEff @ "stateRepl" repl initialState + +-- | +-- Do 'Loop' of 'Read', 'eval', and 'Print', +-- with the startup options. +-- +-- The state of `ReplState` is initialized before the one of "READ-EVAL-PRINT" of the "LOOP" is ran. +-- +-- If some command line arguments are given, enable debug mode. +-- Debug mode shows the parse and the evaluation's optionally result. +repl :: Eff '["stateRepl" >: State ReplState, IOEff] () +repl = do + loopIsRequired <- view _iso <$> runMaybeEff @ "maybe" rep + modifyEff #stateRepl $ \x -> x { replLogs = emptyDebugLog } + when loopIsRequired repl + +-- | +-- Do 'Read', 'Eval', and 'Print' of 'REPL'. +-- Return False if Ctrl+d is input. +-- Return True otherwise. +-- +-- If @rep@ throws a () of the error, it means what the loop of REP exiting is required. +rep :: Eff '[ "maybe" >: MaybeEff + , "stateRepl" >: State ReplState + , IOEff + ] () +rep = do + input <- castEff readPhase + evalResult <- castEff $ evalPhase input + printPhase evalResult + + +-- | +-- Read line from stdin. +-- If stdin gives to interrupt, return Nothing. +-- If it's not, return it and it is added to history file +readPhase :: Eff '["maybe" >: MaybeEff, IOEff] Text +readPhase = do + maybeInput <- liftIOEff $ R.readline "zuramaru> " + liftIOEff $ mapM R.addHistory maybeInput + T.pack <$> liftMaybe maybeInput + +-- | Lift up `Nothing` to the failure of the whole +liftMaybe :: Associate "maybe" MaybeEff xs => Maybe a -> Eff xs a +liftMaybe Nothing = throwEff #maybe () +liftMaybe (Just x) = return x + + +-- | +-- Do parse and evaluate a Text to a SExpr. +-- Return @SExpr@ (maru's AST) if both parse and evaluation is succeed. +-- Otherwise, return a error result. +-- +-- Execute the evaluation. +-- A state of @DebugLogs@ is updated by got logs which can be gotten in the evaluation. +-- A state of @MaruEnv@ is updated by new environment of the result. +evalPhase :: Text -> Eff '["stateRepl" >: State ReplState, IOEff] EvalPhaseResult +evalPhase code = do + evalIsNeeded <- gets $ doEval . replOpts + -- Get a real evaluator or an empty evaluator. + -- The empty evaluator doesn't touch any arguments. + let eval' = if evalIsNeeded then E.eval + else fakeEval + case Parser.debugParse code of + (Left parseErrorResult, _) -> return $ ParseError parseErrorResult + (Right sexpr', xs) -> do + let parseLogs = map unParseLog xs + parseLog = "parse result: " <> showt sexpr' + let sexpr = preprocess sexpr' + preprLog = "preprocess result: " <> showt sexpr + replLogsA . evalLogsA <>= (parseLog : parseLogs) + replLogsA . evalLogsA <>= [preprLog] + env <- gets replEnv + evalResult <- liftIOEff $ eval' env sexpr + case evalResult of + Left evalErrorResult -> return $ EvalError evalErrorResult + Right (result, newEnv, steps) -> do + replEnvA .= newEnv + replLogsA . evalLogsA %= (++ reportSteps steps) + return $ RightResult result + where + -- Do nothing + fakeEval :: Evaluator + fakeEval = (return .) . (Right .) . flip (,,[]) + + +-- | Do 'Print' for a result of 'Read' and 'Eval' +printPhase :: ( Associate "stateRepl" (State ReplState) xs + , IOEffAssociation xs + ) => EvalPhaseResult -> Eff xs () +printPhase result = do + DebugLogs readLogs' evalLogs' <- gets replLogs + debugMode' <- gets $ debugMode . replOpts + liftIOEff $ case result of + ParseError e -> TIO.putStrLn . T.pack . forgetMatrixAnnotation $ Parser.parseErrorPretty e + EvalError e -> TIO.putStrLn . T.pack $ show e + RightResult sexpr -> TIO.putStrLn $ MT.readable sexpr + liftIOEff . when debugMode' $ do + forM_ readLogs' $ TIO.putStrLn . ("(readPhase): " <>) + forM_ evalLogs' $ TIO.putStrLn . ("(evalPhase): " <>) + where + --NOTE: A result of Megaparse's `parseErrorPretty` may have about column and row of an error + forgetMatrixAnnotation :: String -> String + forgetMatrixAnnotation parseErrorInfo = + case tailMay $ lines parseErrorInfo of + Nothing -> "" + Just xs -> unlines xs + + +-- | +-- An isomorphism of between `Maybe ()` and `Bool`. +-- `Just ()` is mapped to `True` +_iso :: Iso' (Maybe ()) Bool +_iso = iso to from + where + to :: Maybe () -> Bool + to (Just ()) = True + to Nothing = False + from :: Bool -> Maybe () + from True = Just () + from False = Nothing diff --git a/src/Maru/Parser.hs b/src/Maru/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Parser.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The parsers +module Maru.Parser + ( parseTest + , prettyPrint + , parseErrorPretty + , parse + , debugParse + , ParseResult + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (mapM_) +import Control.Monad.Fail (fail) +import Maru.Type.Parser (ParseLog(..), ParseErrorResult, MaruParser, runMaruParser) +import Maru.Type.SExpr +import Prelude hiding (fail) +import Safe (readMay) +import qualified Data.Text.IO as TIO +import qualified Maru.Type.SExpr as MTS +import qualified Text.Megaparsec as P + +type ParseResult = Either ParseErrorResult CallowSExpr + + +-- | Parse code to AST, and show AST and logs +parseTest :: SourceCode -> IO () +parseTest = prettyPrint . debugParse + +-- | Pretty print result of debugParse +prettyPrint :: (ParseResult, [ParseLog]) -> IO () +prettyPrint (parseResult, logs) = do + mapM_ (TIO.putStrLn . unParseLog) logs + putStrLn "" + case parseResult of + Left e -> putStrLn $ P.parseErrorPretty e + Right a -> putStrLn $ "Success:\n> " ++ show a + +-- | Parse code to AST without logs +parse :: SourceCode -> ParseResult +parse = fst . debugParse + +-- | Parse code to AST with logs +debugParse :: SourceCode -> (ParseResult, [ParseLog]) +debugParse = runMaruParser sexprParser + +parseErrorPretty :: ParseErrorResult -> String +parseErrorPretty = P.parseErrorPretty + + +sexprParser :: MaruParser CallowSExpr +sexprParser = do + P.space + quoteParser <<> atomParser <<> listParser + where + -- but "(quote x)" is not parsed to `Quote (AtomSymbol "x")` in here, + -- it is parsed to `Cons (AtomSymbol "quote") (Cons (AtomSymbol "x") Nil)` + -- in the outer of here + quoteParser :: MaruParser CallowSExpr + quoteParser = do + P.char '\'' + Quote' <$> sexprParser + + atomParser :: MaruParser CallowSExpr + atomParser = (numberParser <<> boolParser <<> symbolParser) <* P.space + + listParser :: MaruParser CallowSExpr + listParser = do + P.char '(' + P.space + xs <- P.many sexprParser + P.space + P.char ')' + P.space + return $ scottEncode' xs + + numberParser :: MaruParser CallowSExpr + numberParser = naturalNumberParser <<> positiveNumberParser <<> negativeNumberParser + + boolParser :: MaruParser CallowSExpr + boolParser = return . AtomBool' =<< judgeBool =<< P.string "true" <|> P.string "false" + + symbolParser :: MaruParser CallowSExpr + symbolParser = return . AtomSymbol' . MTS.pack =<< P.some (P.noneOf ['\'', '(', ')', ' ']) + + naturalNumberParser :: MaruParser CallowSExpr + naturalNumberParser = return . AtomInt' =<< read' =<< P.some P.digitChar + + positiveNumberParser :: MaruParser CallowSExpr + positiveNumberParser = do + P.char '+' + numberParser + + negativeNumberParser :: MaruParser CallowSExpr + negativeNumberParser = do + P.char '-' + txt <- P.some P.digitChar + AtomInt' . negate <$> read' txt + + +-- | +-- Return the constant successive parser for `Bool` if the string is "true" or "false". +-- Return the constant failure parser if it is the another string. +judgeBool :: String -> MaruParser Bool +judgeBool "true" = return True +judgeBool "false" = return False +judgeBool _ = fail "boolParser is failed" + +-- | +-- Read it, +-- but if the reading is failed, the whole of `MaruParser` context to be failure. +-- Otherwise, the result into the context and Return it. +read' :: Read a => String -> MaruParser a +read' x = + case readMay x of + Nothing -> fail "read': fatal error! a reading the `String` to the `Read` value is failed" + Just x' -> return x' + + +infixr 5 <<> +-- | Don't consume the tokens if the left parser is failed +(<<>) :: MaruParser a -> MaruParser a -> MaruParser a +x <<> y = P.try x <|> y diff --git a/src/Maru/Preprocessor.hs b/src/Maru/Preprocessor.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Preprocessor.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The preprocessor between 'CallowSExpr' and 'SExpr' +module Maru.Preprocessor + ( preprocess + ) where + +import Maru.Type + +-- | +-- Process a 'SExpr' to the desired form before 'Maru.Eval.eval' +-- +-- Regard the symbol of "quote" to a quote macro +-- +-- >>> preprocess $ Cons' (AtomSymbol' "quote") (Cons' (AtomInt' 10) Nil') +-- Quote (AtomInt 10) +preprocess :: CallowSExpr -> SExpr +preprocess (Cons' (AtomSymbol' "quote") (Cons' x Nil')) = Quote $ growUp x +preprocess x = growUp x diff --git a/src/Maru/QQ.hs b/src/Maru/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Maru/QQ.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Present compile time lisp (zuramaru) literals as quasi-quotes. +-- +-- The compile time inline lisp is contained :sunny: +-- +-- You can use 'Maru.QQ.ShortName' instead of these functions, +-- if you don't worry name conflictions. +-- +-- These requires to +-- ` +-- import Maru.Type.SExpr (SExpr(..), MaruSymbol(..)) +-- ` +-- and add `text` to your package.yaml or {project}.cabal (below is a package.yaml example) +-- ` +-- dependencies: +-- - text +-- ` +-- +-- and optionally requirements are existent, please see below. +-- +-- If you want to use as patterns +-- (e.g. `let ![parse|123|] = AtomInt 123`) +-- ` +-- {-# LANGUAGE OverloadedStrings #-} +-- ` +-- +-- If you want to use as types +-- (e.g. `f :: [parse|(1 2)|]`) +-- ` +-- {-# LANGUAGE DataKinds #-} +-- ` +module Maru.QQ + ( parse + , parsePreprocess + , zurae + ) where + +import Control.Arrow ((>>>)) +import Data.Text (Text) +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Maru.Type (SExpr(..), MaruSymbol(..), CallowSExpr(..)) +import qualified Data.Text as T +import qualified Maru.Eval as Maru +import qualified Maru.Parser as Maru +import qualified Maru.Preprocessor as Maru + +-- $setup +-- >>> :set -XQuasiQuotes +-- >>> :set -XDataKinds +-- >>> :set -XOverloadedStrings +-- >>> import Data.Singletons (sing, fromSing) +-- >>> import Maru.Type.Parser (ParseErrorResult) +-- >>> import Maru.Type.SExpr (SourceCode) +-- >>> import Maru.Type.TypeLevel (HighSExpr(..), Sing(..)) +-- >>> import System.IO.Silently (silence) + +--TODO: Implement tests to check the compiler errors (See 'Maru.QQ.parse', 'Maru.QQ.zurae' documentation for conditions of the compile error) +-- (What can I implement it ?) + + +textE :: Text -> Exp +textE t = + let x = T.unpack t + in VarE (mkName "Data.Text.pack") `AppE` LitE (StringL x) + +intL :: Int -> Lit +intL = IntegerL . fromIntegral + +boolP :: Bool -> Pat +boolP x = ConP (mkName $ show x) [] + +-- | A value `x :: Int` as a type `x :: 'Nat'` +intT :: Int -> Type +intT = LitT . NumTyLit . fromIntegral + +-- | A value `x :: Bool` as a type `x :: 'Bool` +boolT :: Bool -> Type +boolT = PromotedT . mkName . show + +-- | A value 'x :: Text' as a type `x :: 'Symbol'` +textSym :: Text -> Type +textSym = LitT . StrTyLit . T.unpack + + +toExp :: SExpr -> Exp +toExp (Cons x y) = ConE (mkName "Cons") `AppE` ParensE (toExp x) `AppE` ParensE (toExp y) +toExp (Quote x) = ConE (mkName "Quote") `AppE` ParensE (toExp x) +toExp Nil = ConE (mkName "Nil") +toExp (AtomInt x) = ConE (mkName "AtomInt") `AppE` LitE (intL x) +toExp (AtomBool x) = ConE (mkName "AtomBool") `AppE` ConE (mkName $ show x) +toExp (AtomSymbol (MaruSymbol x)) = ConE (mkName "AtomSymbol") `AppE` + ParensE (ConE (mkName "MaruSymbol") `AppE` textE x) + + +toPat :: SExpr -> Pat +toPat (Cons x y) = ConP (mkName "Cons") [toPat x, toPat y] +toPat (Quote x) = ConP (mkName "Quote") [toPat x] +toPat Nil = ConP (mkName "Nil") [] +toPat (AtomInt x) = ConP (mkName "AtomInt") [LitP $ intL x] +toPat (AtomBool x) = ConP (mkName "AtomBool") [boolP x] +-- This requires OverloadedStrings +toPat (AtomSymbol (MaruSymbol x)) = ConP (mkName "AtomSymbol") [ConP (mkName "MaruSymbol") [LitP . StringL $ T.unpack x]] + + +toType :: SExpr -> Type +toType (Cons x y) = PromotedT (mkName "HCons") `AppT` ParensT (toType x) `AppT` ParensT (toType y) +toType (Quote x) = PromotedT (mkName "HQuote") `AppT` ParensT (toType x) +toType Nil = PromotedT (mkName "HNil") +--NOTE: Should specify a branch when `x < 0` ? or NumTyLit satisfies ? +toType (AtomInt x) = PromotedT (mkName "HAtomInt") `AppT` intT x +toType (AtomBool x) = PromotedT (mkName "HAtomBool") `AppT` boolT x +toType (AtomSymbol (MaruSymbol x)) = PromotedT (mkName "HAtomSymbol") `AppT` textSym x + + +-- | +-- Expand a code to 'SExpr' +-- if it can be parsed by 'Maru.Parser.parse' +-- (or to be compiled error). +-- +-- Occure the compile error if it cannot be parsed. +-- +-- >>> :{ +-- >>> let p :: SourceCode -> Either ParseErrorResult SExpr +-- >>> p x = growUp <$> Maru.parse x -- with the empty preprocessor (growUp) +-- >>> :} +-- +-- As expressions +-- +-- >>> Right [parse|123|] == p "123" +-- True +-- >>> Right [parse|abc|] == p "abc" +-- True +-- >>> Right [parse|(123 456)|] == p "(123 456)" +-- True +-- +-- As patterns +-- +-- >>> case AtomInt 123 of; [parse|123|] -> "good" +-- "good" +-- >>> case AtomInt 000 of; [parse|123|] -> "bad"; AtomInt _ -> "good" +-- "good" +-- >>> case AtomSymbol "x" of; [parse|x|] -> "good" +-- "good" +-- >>> case Quote (AtomInt 10) of; [parse|'10|] -> "good" +-- "good" +-- >>> case Cons (AtomSymbol "x") (Cons (AtomInt 10) Nil) of; [parse|(x 10)|] -> "good" +-- "good" +-- +-- As types (compile time calculations) +-- +-- >>> fromSing (sing :: Sing [parse|10|]) +-- AtomInt 10 +-- >>> fromSing (sing :: Sing [parse|konoko|]) +-- AtomSymbol "konoko" +-- >>> fromSing (sing :: Sing [parse|(1 2 3)|]) +-- Cons (AtomInt 1) (Cons (AtomInt 2) (Cons (AtomInt 3) Nil)) +parse :: QuasiQuoter +parse = QuasiQuoter + { quoteExp = power toExp + , quotePat = power toPat + , quoteType = power toType + , quoteDec = error "Maru.QQ.parse: the expansion to `[Dec]` (`quoteDec`) isn't support supported" + } + where + power :: (SExpr -> a) -> String -> Q a + power f = T.pack >>> Maru.parse >>> \case + Left e -> fail $ Maru.parseErrorPretty e + Right a -> return . f $ growUp a + + +-- | +-- Similar to 'parse' but 'Maru.preprocessor.preprocess' is appended +-- +-- >>> :{ +-- >>> let pp :: SourceCode -> Either ParseErrorResult SExpr +-- >>> pp code = Maru.preprocess <$> Maru.parse code +-- >>> :} +-- +-- >>> Right [parsePreprocess|sugar|] == pp "sugar" +-- True +-- >>> Right [parsePreprocess|10|] == pp "10" +-- True +-- >>> Right [parsePreprocess|(1 2 3)|] == pp "(1 2 3)" +-- True +-- >>> Right [parsePreprocess|'10|] == pp "'10" +-- True +parsePreprocess :: QuasiQuoter +parsePreprocess = QuasiQuoter + { quoteExp = power toExp + , quotePat = power toPat + , quoteType = power toType + , quoteDec = error "Maru.QQ.parsePreprocess: the expansion to `[Dec]` (`quoteDec`) isn't support supported" + } + where + power :: (SExpr -> a) -> String -> Q a + power f = T.pack >>> Maru.parse >>> \case + Left e -> fail $ Maru.parseErrorPretty e + Right a -> return . f $ Maru.preprocess a + + +-- | +-- Similar to 'parsePreprocess' but it is ran in the compile time, +-- Occure the side effects, +-- and Return the evaluated result. +-- +-- Occure the compile error if the code throws exceptions. +-- +-- この関数名zuraeの発音はずら〜（ずらあ）です。 +-- (the e suffix means an 'e'valuation) +-- +-- NOTICE: +-- Please be careful to the halting problem. +-- The halting safety is abandon +-- because this ('Maru.Eval.eval') is turing-complete in the compile time :D +-- +-- >>> :{ +-- >>> let force :: SourceCode -> IO SExpr +-- >>> force code = do +-- >>> let (Right sexpr) = Maru.preprocess <$> Maru.parse code +-- >>> Right (result, _, _) <- silence $ Maru.eval Maru.initialEnv sexpr +-- >>> return result +-- >>> :} +-- +-- >>> (==) <$> return [zurae|10|] <*> force "10" +-- True +-- >>> (==) <$> return [zurae|'sugar|] <*> force "'sugar" +-- True +-- >>> (==) <$> return [zurae|'(1 2 3)|] <*> force "'(1 2 3)" +-- True +-- >>> (==) <$> return [zurae|(print 10)|] <*> force "(print 10)" +-- 10True +zurae :: QuasiQuoter +zurae = QuasiQuoter + { quoteExp = power toExp + , quotePat = power toPat + , quoteType = power toType + , quoteDec = error "Maru.QQ.zurae: the expansion to `[Dec]` (`quoteDec`) isn't support supported" + } + where + power :: (SExpr -> a) -> String -> Q a + power f = T.pack >>> Maru.parse >>> fmap Maru.preprocess >>> \case + Left e -> fail $ Maru.parseErrorPretty e + Right sexpr -> do + result <- runIO $ Maru.eval Maru.initialEnv sexpr + case result of + Left e -> fail $ "Maru.QQ.zurae: an error is occured in the compile time: " ++ show e + Right (sexpr, _, _) -> return $ f sexpr diff --git a/src/Maru/QQ/ShortName.hs b/src/Maru/QQ/ShortName.hs new file mode 100644 --- /dev/null +++ b/src/Maru/QQ/ShortName.hs @@ -0,0 +1,17 @@ +-- | Export short names of quasi-quotes in 'Maru.QQ', for easy to use +module Maru.QQ.ShortName where + +import Language.Haskell.TH.Quote (QuasiQuoter) +import qualified Maru.QQ as O + +-- | parse +p :: QuasiQuoter +p = O.parse + +-- | parsePreprocess +pp :: QuasiQuoter +pp = O.parsePreprocess + +-- | zurae +z :: QuasiQuoter +z = O.zurae diff --git a/src/Maru/TH.hs b/src/Maru/TH.hs new file mode 100644 --- /dev/null +++ b/src/Maru/TH.hs @@ -0,0 +1,18 @@ +-- | +-- Avoid 'GHC stage restriction' of TemplateHaskell. +-- Define 'DecsQ' functions. +module Maru.TH + ( makeLensesA + ) where + +import Control.Lens ((&), (.~), DefName(..), makeLensesWith, lensRules, lensField) +import Language.Haskell.TH (Name, mkName, nameBase, DecsQ) + +-- | +-- makeLenses with 'A' suffix. +-- e.g. replEnv -> replEnvA +makeLensesA :: Name -> DecsQ +makeLensesA = makeLensesWith (lensRules & lensField .~ addSuffix) + where + addSuffix :: Name -> [Name] -> Name -> [DefName] + addSuffix _ _ recordName = [TopName . mkName $ nameBase recordName ++ "A"] diff --git a/src/Maru/Type.hs b/src/Maru/Type.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Type.hs @@ -0,0 +1,10 @@ +-- | Re exports modules of the under of Maru.Type +module Maru.Type + ( module Maru.Type.Eval + , module Maru.Type.Parser + , module Maru.Type.SExpr + ) where + +import Maru.Type.Eval +import Maru.Type.Parser +import Maru.Type.SExpr diff --git a/src/Maru/Type/Eval.hs b/src/Maru/Type/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Type/Eval.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Integrate types of extensible's Effect. +-- +-- `MaruMacro` is evaluated by `MaruEvaluator`. +-- `MaruFunc` is calculated by `MaruCalculator`. +module Maru.Type.Eval + ( Fail + , FailKey + , FailValue + , FailAssociation + , throwFail + , includeFail + , includeFail' + , SimplificationSteps + , reportSteps + , SimplifSteps + , SimplifStepsKey + , SimplifStepsValue + , SimplifStepsAssociation + , MaruScopes + , MaruScopesKey + , MaruScopesValue + , MaruScopesAssociation + , insertGlobalVar + , newScope + , popNewerScope + , MaruEnv + , getMaruEnv + , putMaruEnv + , modifyMaruEnv + , IOEff + , IOEffKey + , IOEffValue + , IOEffAssociation + , liftIOEff + , ExceptionCause + , MaruEvaluator + , runMaruEvaluator + , newSymbol + , MaruScope + , MaruFunc (..) + , MaruMacro (..) + , lookup + , lookupVar + , (^$) + , MaruCalculator + , runMaruCalculator + , First' (..) + , first' + , expandVars + , substituteVar + ) where + +import Control.Lens hiding ((<|)) +import Control.Monad.Fail (MonadFail(..)) +import Data.Extensible +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import Data.Map.Lazy (Map) +import Data.Monoid (First(..)) +import Data.Proxy (Proxy(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Text (Text) +import Data.Typeable (Typeable, typeRep) +import Data.Unique (newUnique, hashUnique) +import Maru.Type.SExpr +import Prelude hiding (fail, lookup) +import TextShow (TextShow(..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Lazy as M +import qualified Data.Text as T +import qualified Maru.Type.SExpr as MTS + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Either +-- >>> import qualified Maru.Eval as E + +-- | A message of @Fail@ +type ExceptionCause = Text + +-- | +-- An effect of @MaruEvaluator@. +-- A possible of the failure. +type Fail = FailKey >: FailValue +type FailKey = "fail" +type FailValue = EitherEff ExceptionCause +-- | `Fail`'s `Associate` +type FailAssociation = Associate FailKey FailValue + +-- | `throwEff` for `Fail` +throwFail :: FailAssociation xs => ExceptionCause -> Eff xs a +throwFail = throwEff #fail + +-- | +-- Include `Maybe` to `Fail` context. +-- If it is Nothing, +-- the whole of `Fail a` to be failed. +includeFail :: FailAssociation xs => ExceptionCause -> Eff xs (Maybe a) -> Eff xs a +includeFail cause mm = do + maybeIt <- mm + case maybeIt of + Nothing -> throwFail cause + Just x -> return x + +-- | Same as `includeFail` +includeFail' :: FailAssociation xs => Eff xs (Either ExceptionCause a) -> Eff xs a +includeFail' e = do + maybeIt <- e + case maybeIt of + Left c -> throwFail c + Right x -> return x + + +-- | A log for 簡約s +type SimplificationSteps = [SExpr] + +-- | +-- Append numbers to steps +-- +-- >>> import Maru.Type.SExpr +-- >>> reportSteps [Cons (AtomInt 1) (Cons (AtomInt 2) Nil), Cons (AtomInt 2) Nil] +-- ["1: (1 2)","2: (2)"] +reportSteps :: SimplificationSteps -> [Text] +reportSteps = zipWith appendStepNumber [1..] . map readable + where + appendStepNumber :: Int -> Text -> Text + appendStepNumber n x = showt n <> ": " <> x + +-- | An effect of @MaruEvaluator@, for logging simplifications +type SimplifSteps = SimplifStepsKey >: SimplifStepsValue +type SimplifStepsKey = "simplifSteps" +type SimplifStepsValue = WriterEff SimplificationSteps +type SimplifStepsAssociation = Associate SimplifStepsKey SimplifStepsValue + + +-- | +-- An effect of @MaruEvaluator@. +-- This is a stack for the lexical scope. +type MaruScopes = MaruScopesKey >: MaruScopesValue +type MaruScopesKey = "maruScopes" +type MaruScopesValue = State MaruEnv +type MaruScopesAssociation = Associate MaruScopesKey MaruScopesValue + +-- | +-- The whole of the runtime state. +-- This is `NonEmpty`, because the global scope is defined with the program startup +-- +-- and +-- +-- 'getMaruEnv >>= return . last' is the toplevel (and this is used as global scope). +-- 'getMaruEnv >>= return . head' is the newest scope. +-- +-- ( This means the cons operation makes a new scope, it is not '++ [x]'. +-- Please see `makeScope`. +-- ) +type MaruEnv = NonEmpty MaruScope + +-- | +-- Insert a variable to the toplevel scope +-- +-- >>> (_, env, _) <- flip runMaruEvaluator E.initialEnv $ insertGlobalVar "x" (AtomInt 10) +-- >>> lookup "x" env +-- Just (AtomInt 10) +insertGlobalVar :: MaruScopesAssociation xs => MaruSymbol -> SExpr -> Eff xs () +insertGlobalVar sym val = do + env <- getMaruEnv + let env' = NE.init env + global = M.insert sym val $ NE.last env + putMaruEnv $ case NE.nonEmpty env' of + Nothing -> (global :| []) + Just env'' -> env'' <> [global] + +-- | +-- Make a scope in the state, with a variable. +-- +-- NOTE: +-- The scope must be created with one or more variables. +-- It keeps any safety. +-- +-- e.g. +-- 1. unintended empty scope is never created +-- 2. high affinity of `MaruEnv` (`NonEmpty`) is kept +newScope :: MaruScopesAssociation xs => MaruSymbol -> SExpr -> Eff xs () +newScope sym val = modifyMaruEnv ([(sym, val)] <|) + +-- | +-- Remove the newest scope (about the newest scope is written in `MaruEnv`), +-- and Return removed scope +popNewerScope :: MaruScopesAssociation xs => Eff xs MaruScope +popNewerScope = do + (newest:|restEnv) <- getMaruEnv + case NE.nonEmpty restEnv of + Nothing -> error "localScope(fatal error!): unexpected empty stack is detected! (In the correct case, the global scope is existed)" + Just restEnv' -> putMaruEnv restEnv' >> return newest + +-- | +-- The runtime state. +-- This associates the variable name and the value. +type MaruScope = Map MaruSymbol SExpr + +-- | `getEff` for `MaruScopes` +getMaruEnv :: MaruScopesAssociation xs => Eff xs MaruEnv +getMaruEnv = getEff #maruScopes + +-- | `putEff` for `MaruScopes` +putMaruEnv :: MaruScopesAssociation xs => MaruEnv -> Eff xs () +putMaruEnv = putEff #maruScopes + +-- | `modifyEff` for `maruScopes` +modifyMaruEnv :: MaruScopesAssociation xs => (MaruEnv -> MaruEnv) -> Eff xs () +modifyMaruEnv = modifyEff #maruScopes + +-- | Find a variable from the whole of the runtime environment with a symbol +lookup :: MaruSymbol -> MaruEnv -> Maybe SExpr +lookup sym xs = getFirst . mconcat . NE.toList $ NE.map (First . M.lookup sym) xs + + +-- | An effect of @MaruEvaluator@, this is same as `IO` in `Eff` +type IOEff = IOEffKey >: IOEffValue +type IOEffKey = "ioEff" +type IOEffValue = IO +type IOEffAssociation = Associate IOEffKey IOEffValue + +-- | `liftEff` for `IOEff` +liftIOEff :: IOEffAssociation xs => IO a -> Eff xs a +liftIOEff = liftEff #ioEff + + +-- | A monad for evaluating a maru's program +type MaruEvaluator = Eff '[Fail, MaruScopes, SimplifSteps, IOEff] + +instance MonadFail MaruEvaluator where + fail = throwFail . T.pack + + +-- | Run an evaluation of @MaruEvaluator a@ +runMaruEvaluator :: MaruEvaluator a -> MaruEnv -> IO (Either ExceptionCause a, MaruEnv, SimplificationSteps) +runMaruEvaluator m env = flatten <$> runMaruEvaluator' m env + where + runMaruEvaluator' :: MaruEvaluator a -> MaruEnv -> IO (((Either ExceptionCause a), MaruEnv), [SExpr]) + runMaruEvaluator' m env = retractEff . runWriterEff . flip runStateEff env $ runEitherEff m + flatten :: ((a, b), c) -> (a, b, c) + flatten ((x, y), z) = (x, y, z) + +-- | +-- Create a symbol of the variable name, +-- it is unique (is not duplicated) in the runtime. +newSymbol :: MaruEvaluator MaruSymbol +newSymbol = ("n" <>) <$> newSymbol' "" + where + -- Take a base of the name. + newSymbol' :: MaruSymbol -> MaruEvaluator MaruSymbol + newSymbol' baseName = do + name <- liftIOEff $ (baseName <>) . MTS.pack . show . hashUnique <$> newUnique + env <- getMaruEnv + case lookup name env of + Nothing -> newSymbol' name + Just _ -> return name + +--NOTE: Can this is alternated by some lens's function ? +-- | +-- This is like `Prism`'s accessor, +-- but don't return result as `Maybe`. +-- +-- Similar to 'x <&> review f' but Nothing is included as a failure of the whole of `MaruEvaluator`. +-- +-- `Typeable` for the error message. +(^$) :: (Typeable s, Typeable a) => MaruEvaluator s -> Getting (First a) s a -> MaruEvaluator a +(m :: MaruEvaluator s) ^$ (acs :: Getting (First a) s a) = do + let typeNameOfS = T.pack . show $ typeRep (Proxy :: Proxy s) + typeNameOfA = T.pack . show $ typeRep (Proxy :: Proxy a) + cause = "(^$): `" <> typeNameOfA <> "` couldn't be getten from `" <> typeNameOfS <> "`" + includeFail cause $ m <&> preview acs + + +-- | +-- This has effects of the part of `MaruEvaluator`. +-- Calculate pure functions. +type MaruCalculator = Eff '[Fail] + +instance MonadFail MaruCalculator where + fail = throwFail . T.pack + +-- | Extract the pure calculation from `MaruCalculator` +runMaruCalculator :: MaruCalculator a -> Either ExceptionCause a +runMaruCalculator = leaveEff . runEitherEff + + +-- | Simular to `First`, but using '`Either` `ExceptionCause`' instead of `Maybe` +newtype First' a = First' + { getFirst' :: Either ExceptionCause a + } deriving (Functor) + +instance Monoid (First' a) where + mempty = First' $ Left "mempty: `First'` couldn't find the right value" + w@(First' (Right _)) `mappend` _ = w + _ `mappend` w@(First' (Right _)) = w + _ `mappend` _ = mempty + + +-- | +-- Like a consturctor, but from '`Maybe` a'. +-- If `Nothing` is given, return `mempty`. +first' :: Maybe a -> First' a +first' (Just a) = First' $ Right a +first' Nothing = mempty + + +-- | +-- A function of maru. +-- This keeps the purity, don't happen effects. +-- +-- Take [`SExpr`] as arguments, its length is checked by each function. +-- If it is not the expected length, `Nothing` maybe given. +-- +-- Notice: +-- +-- The function is Haskell's function, is represented by Haskell. +-- The function is not maru's (runtime's) function (cannot be defined in the runtime). +newtype MaruFunc = MaruFunc + { execFunc :: [SExpr] -> MaruCalculator SExpr + } + +-- | +-- A macro of maru, +-- this means the impure function. +-- +-- Similar to `MaruFunc`, +-- but this is possibility to update the state of the environment. +newtype MaruMacro = MaruMacro + { execMacro :: SExpr -> MaruEvaluator SExpr + } + + +-- | +-- Take a variable from `MaruScopes` effect. +-- If `sym` is not exists, the whole of this `Eff` to be failed +lookupVar :: forall xs. + ( FailAssociation xs + , MaruScopesAssociation xs + ) => MaruSymbol -> Eff xs SExpr +lookupVar sym = do + env <- getMaruEnv + let cause = "A symbol '" <> unMaruSymbol sym <> "' is not found" + includeFail cause . return $ lookup sym env + + +-- | +-- Expand the value of the variables, but these are not evaluated. +-- +-- And +, -, *, and / are not expanded +-- (because it is regarded as like the axioms) +-- +-- simply expanding +-- +-- >>> (sexpr, _, _) <- flip runMaruEvaluator E.initialEnv $ newScope "x" (AtomInt 10) >> expandVars (AtomSymbol "x") +-- >>> sexpr +-- Right (AtomInt 10) +-- +-- multi variables +-- +-- >>> (sexpr, _, _) <- flip runMaruEvaluator E.initialEnv $ newScope "x" (AtomInt 10) >> newScope "y" (AtomBool True) >> expandVars (Cons (AtomSymbol "x") (Cons (AtomSymbol "y") Nil)) +-- >>> sexpr +-- Right (Cons (AtomInt 10) (Cons (AtomBool True) Nil)) +-- +-- nested expanding +-- +-- >>> (sexpr, _, _) <- flip runMaruEvaluator E.initialEnv $ newScope "x" (AtomInt 10) >> newScope "y" (AtomSymbol "x") >> expandVars (AtomSymbol "y") +-- >>> sexpr +-- Right (AtomInt 10) +-- +-- the quote is kept +-- +-- >>> (sexpr, _, _) <- flip runMaruEvaluator E.initialEnv $ expandVars (Quote (AtomSymbol "xxx")) +-- >>> sexpr +-- Right (Quote (AtomSymbol "xxx")) +expandVars :: (MaruScopesAssociation xs, FailAssociation xs) => SExpr -> Eff xs SExpr +expandVars (AtomSymbol "+") = return $ AtomSymbol "+" +expandVars (AtomSymbol "-") = return $ AtomSymbol "-" +expandVars (AtomSymbol "*") = return $ AtomSymbol "*" +expandVars (AtomSymbol "/") = return $ AtomSymbol "/" +expandVars Nil = return Nil +expandVars (AtomInt x) = return $ AtomInt x +expandVars (AtomBool x) = return $ AtomBool x +expandVars (Cons x y) = Cons <$> expandVars x <*> expandVars y +expandVars (AtomSymbol var) = lookupVar var >>= expandVars +expandVars (Quote x) = return $ Quote x + + +-- | +-- Substitute a value to a variable. +-- +-- "x" is substituted by `AtomInt 10` in `Cons (AtomInt 1) (Cons (AtomSymbol "x") Nil)`. +-- +-- >>> substituteVar "x" (AtomInt 10) $ Cons (AtomInt 1) (Cons (AtomSymbol "x") Nil) +-- Cons (AtomInt 1) (Cons (AtomInt 10) Nil) +-- +-- >>> substituteVar "x" (AtomInt 10) $ Cons (AtomSymbol "x") (Cons (AtomSymbol "x") Nil) +-- Cons (AtomInt 10) (Cons (AtomInt 10) Nil) +substituteVar :: MaruSymbol -> SExpr -> SExpr -> SExpr +substituteVar var val (AtomSymbol var') = + if var == var' then val + else AtomSymbol var' +substituteVar _ _ Nil = Nil +substituteVar _ _ (AtomInt x) = AtomInt x +substituteVar _ _ (AtomBool x) = AtomBool x +substituteVar _ _ (Quote x) = Quote x +substituteVar var val (Cons x y) = Cons (substituteVar var val x) (substituteVar var val y) diff --git a/src/Maru/Type/Parser.hs b/src/Maru/Type/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Type/Parser.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | The type for Maru.Parser +module Maru.Type.Parser + ( ParseLog (..) + , ParseLogs + , MaruParser + , runMaruParser + , tell' + , ParseErrorResult + ) where + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fail (MonadFail) +import Control.Monad.State.Class (MonadState, modify) +import Control.Monad.State.Lazy (State, runState) +import Data.Sequence (Seq, (|>)) +import Data.String (IsString) +import Data.Text (Text) +import Maru.Type.SExpr +import Text.Megaparsec (ParsecT, ParseError, Dec, runParserT) +import Text.Megaparsec.Prim (MonadParsec) +import qualified Data.Text as T +import qualified GHC.Exts as L + +-- | The parse result of the failure +type ParseErrorResult = ParseError MaruToken Dec + +-- | A log message of the parsing, for debug +newtype ParseLog = ParseLog { unParseLog :: Text } + deriving (IsString, Monoid) + +instance Show ParseLog where + show = show . T.unpack . unParseLog + +type ParseLogs = Seq ParseLog + +-- | +-- A parser for the code of maru +-- +-- NOTE: +-- This `MonadState` instance is instead of `MonadWriter`, +-- because `ParsecT` is not the `MonadWriter` instance. +newtype MaruParser a = MaruParser { unMaruParser :: ParsecT Dec Text (State ParseLogs) a } + deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadState ParseLogs + , MonadParsec Dec Text + , MonadFail + ) + +-- | +-- Run parser and extract result and logs. +runMaruParser :: MaruParser a -> Text -> (Either ParseErrorResult a, [ParseLog]) +runMaruParser parser source = + let bareness = unMaruParser parser + (result, logs) = flip runState [] $ runParserT bareness "" source + in (result, L.toList logs) + +-- | Append a log to head of _parseLogs in the parsing +tell' :: ParseLog -> MaruParser () +tell' log = modify (|> log) diff --git a/src/Maru/Type/SExpr.hs b/src/Maru/Type/SExpr.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Type/SExpr.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + + +-- | Common types for zuramaru +module Maru.Type.SExpr + ( SourceCode + , MaruToken + , CallowSExpr(..) + , pattern Cons' + , pattern Nil' + , pattern AtomInt' + , pattern AtomBool' + , pattern AtomSymbol' + , pattern Quote' + , SExpr(..) + , isAtomInt + , unAtomInt + , isAtomSymbol + , unAtomSymbol + , SExprLike(..) + , readable + , MaruSymbol(..) + , pack + , unpack + , asSymbolList + , scottEncode + , scottDecode + , scottEncode' + , _Cons + , _Nil + , _AtomInt + , _AtomSymbol + , SExprIntBullet(..) + , intBullet + ) where + +import Control.Lens hiding (_Cons) +import Data.Data (Data) +import Data.List (foldl') +import Data.MonoTraversable (MonoFunctor(..), Element) +import Data.Monoid ((<>)) +import Data.Profunctor (dimap) +import Data.Semigroup (Semigroup) +import Data.String (IsString) +import Data.Text (Text) +import Data.Typeable (Typeable) +import TextShow (TextShow, showb, showt) +import qualified Data.Text as T +import qualified Text.Megaparsec as P +import qualified TextShow as TS + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens ((^?)) +-- >>> import Maru.Parser (parse) +-- >>> import Maru.Preprocessor (preprocess) + +--TODO: Declare as newtype of Text +-- | +-- The format for the code of maru. +-- (This doesn't mean a file path of the code.) +type SourceCode = Text + +-- | The format for the token of `MaruParser` +type MaruToken = P.Token Text + + +-- | +-- Never preprocessed ('Maru.Preprocessor.preprocess') 'SExpr', +-- this is used only between the parser and the preprocessor. +-- +-- This should not be used in the evaluator, +-- and use 'SExpr' instead of this in the evaluator. +-- +-- This is simply isomorphic with 'SExpr', please see 'SExpr' the about of this. +data CallowSExpr = CallowSExpr { growUp :: SExpr } + deriving (Show, Eq, Data, Typeable) + +pattern Cons' :: CallowSExpr -> CallowSExpr -> CallowSExpr +pattern Cons' x y <- CallowSExpr (Cons (CallowSExpr -> x) (CallowSExpr -> y)) + where + Cons' x y = CallowSExpr (Cons (growUp x) (growUp y)) + +pattern Nil' :: CallowSExpr +pattern Nil' = CallowSExpr Nil + +pattern AtomInt' :: Int -> CallowSExpr +pattern AtomInt' x = CallowSExpr (AtomInt x) + +pattern AtomBool' :: Bool -> CallowSExpr +pattern AtomBool' x = CallowSExpr (AtomBool x) + +pattern AtomSymbol' :: MaruSymbol -> CallowSExpr +pattern AtomSymbol' x = CallowSExpr (AtomSymbol x) + +pattern Quote' :: CallowSExpr -> CallowSExpr +pattern Quote' x <- x + where + Quote' (CallowSExpr x) = CallowSExpr (Quote x) + +instance TextShow CallowSExpr where + showb = showb . growUp + + +-- | n-ary tree and terms +data SExpr = Cons SExpr SExpr -- ^ Appending list and list + | Nil -- ^ A representation of empty list + | AtomInt Int -- ^ A pattern of the atom for `Int` + | AtomBool Bool -- ^ A pattern of the atom for `Bool` + | AtomSymbol MaruSymbol -- ^ A pattern of the atom for `MaruSymbol` + | Quote SExpr -- ^ Delays the evaluation of a 'SExpr' + deriving (Show, Eq, Data, Typeable) + +-- | +-- >>> isAtomInt $ AtomInt 10 +-- True +-- >>> isAtomInt Nil +-- False +-- >>> isAtomInt $ AtomSymbol "" +-- False +isAtomInt :: SExpr -> Bool +isAtomInt (AtomInt _) = True +isAtomInt _ = False + +-- | +-- Extract `Int` from a term of `AtomInt`. +-- +-- >>> unAtomInt $ AtomInt 10 +-- Just 10 +-- >>> unAtomInt $ AtomSymbol ":D" +-- Nothing +-- >>> unAtomInt $ Cons (AtomInt 10) (AtomInt 20) +-- Nothing +unAtomInt :: SExpr -> Maybe Int +unAtomInt (AtomInt x) = Just x +unAtomInt _ = Nothing + +-- | +-- >>> isAtomSymbol $ AtomSymbol "x" +-- True +-- >>> isAtomSymbol Nil +-- False +-- >>> isAtomSymbol $ AtomInt 10 +-- False +isAtomSymbol :: SExpr -> Bool +isAtomSymbol (AtomSymbol _) = True +isAtomSymbol _ = False + +-- | Similar to `unAtomInt` +unAtomSymbol :: SExpr -> Maybe MaruSymbol +unAtomSymbol (AtomSymbol x) = Just x +unAtomSymbol _ = Nothing + +-- | Same as Show +instance TextShow SExpr where + showb = TS.fromString . show + +-- | Shot only the `AtomInt`s by `omap` +newtype SExprIntBullet = SExprIntBullet + { unSExprIntBullet :: SExpr + } + +type instance Element SExprIntBullet = Int + +instance MonoFunctor SExprIntBullet where + omap f (SExprIntBullet (AtomInt x)) = SExprIntBullet . AtomInt $ f x + omap _ x = x + +-- | Apply by `omap` a function to a `SExprIntBullet` with wrapping and unwrapping +intBullet :: (Int -> Int) -> SExpr -> SExpr +intBullet f xs = dimap SExprIntBullet unSExprIntBullet (omap f) xs + + +-- | A symbol of `MaruEnv`, but this is not meaning a symbol of maru side +newtype MaruSymbol = MaruSymbol { unMaruSymbol :: Text } + deriving (IsString, Semigroup, Monoid, Eq, Ord, Data, Typeable) + +--TODO: `show x` should be `"MaruSymbol " ++ show (unpack x)` +instance Show MaruSymbol where + show x = show $ unpack x + +instance TextShow MaruSymbol where + showb = TS.fromString . show + +-- | +-- Wrap `String`. +-- If you want to wrap `Text`, please use `MaruSymbol` value constructor instead. +pack :: String -> MaruSymbol +pack = MaruSymbol . T.pack + +-- | A dual of `pack` +unpack :: MaruSymbol -> String +unpack = T.unpack . unMaruSymbol + +-- | +-- A `Prism` accessor. +-- +-- Get `Nothing` if [`SExpr`] includes non `AtomSymbol`. +-- Get all `AtomSymbol` otherwise. +-- +-- >>> [AtomSymbol "x", AtomSymbol "y"] ^? asSymbolList +-- Just ["x","y"] +-- +-- >>> [AtomInt 1, AtomSymbol "y"] ^? asSymbolList +-- Nothing +asSymbolList :: Prism' [SExpr] [MaruSymbol] +asSymbolList = prism from to + where + from :: [MaruSymbol] -> [SExpr] + from = map AtomSymbol + to :: [SExpr] -> Either [SExpr] [MaruSymbol] + to xs = case (filter (not . isAtomSymbol) xs, mapM unAtomSymbol xs) of + ([], Just xs') -> Right xs' + (_, _) -> Left xs + + +--TODO: this maybe not needed +-- | 'a' can be represented as `SExpr` +class SExprLike a where + -- | 'a' can be converted as `SExpr` + wrap :: a -> SExpr + +instance SExprLike Int where + wrap = AtomInt + +--FIXME: Text is not MaruSymbol !! +-- | As a symbol +instance SExprLike Text where + wrap = AtomSymbol . MaruSymbol + + +-- | +-- Show 'SExpr' as the human readable syntax. +-- This is the inverse function of the parser, +-- if the format is ignored (e.g. '( + 1 2)` =~ '(+ 1 2)'). +-- +-- vvv invertibilities for 'SExpr' vvv +-- +-- >>> readable . preprocess <$> parse "10" +-- Right "10" +-- >>> (preprocess <$>) . parse . readable $ AtomInt 10 +-- Right (AtomInt 10) +-- +-- >>> readable . preprocess <$> parse "true" +-- Right "true" +-- >>> (preprocess <$>) . parse . readable $ AtomBool True +-- Right (AtomBool True) +-- +-- >>> readable . preprocess <$> parse "(+ 1 2)" +-- Right "(+ 1 2)" +-- >>> let result = (preprocess <$>) . parse . readable $ Cons (AtomSymbol "+") (Cons (AtomInt 1) (Cons (AtomInt 2) Nil)) +-- >>> result == Right (Cons (AtomSymbol "+") (Cons (AtomInt 1) (Cons (AtomInt 2) Nil))) +-- True +readable :: SExpr -> Text +readable (Cons x y) = + let innerListSyntax = foldl' (<<>>) "" . map readable $ scottDecode y + in "(" <> readable x <<>> innerListSyntax <> ")" + where + a <<>> "" = a + "" <<>> b = b + a <<>> b = a <> " " <> b +readable Nil = "()" +readable (AtomSymbol (MaruSymbol x)) = x +readable (AtomInt x) = showt x +readable (AtomBool True) = "true" +readable (AtomBool False) = "false" +readable (Quote x) = "(quote " <> readable x <> ")" + + +-- | +-- Concatenate `SExpr` by `Cons` +-- +-- [1, (2 3)] +-- +-- >>> xs = [AtomInt 1, Cons (Cons (AtomInt 2) (Cons (AtomInt 3) Nil)) Nil] :: [SExpr] +-- >>> scottEncode xs +-- Cons (AtomInt 1) (Cons (Cons (Cons (AtomInt 2) (Cons (AtomInt 3) Nil)) Nil) Nil) +-- +-- [1, 2, 3] +-- +-- >>> ys = [AtomInt 1, AtomInt 2, AtomInt 3] :: [SExpr] +-- >>> scottEncode ys +-- Cons (AtomInt 1) (Cons (AtomInt 2) (Cons (AtomInt 3) Nil)) +-- +-- [1, ()] +-- +-- >>> zs = [AtomInt 1, Nil] :: [SExpr] +-- >>> scottEncode zs +-- Cons (AtomInt 1) (Cons Nil Nil) +scottEncode :: [SExpr] -> SExpr +scottEncode [] = Nil +scottEncode (x:xs) = Cons x $ scottEncode xs + +-- | +-- The inverse function of `scottEncode` +-- +-- >>> let xs = Cons (AtomInt 1) (Cons (AtomInt 2) Nil) +-- >>> scottDecode xs +-- [AtomInt 1,AtomInt 2] +-- >>> scottDecode $ Cons (AtomInt 10) Nil +-- [AtomInt 10] +-- >>> scottDecode $ Cons Nil Nil +-- [Nil] +scottDecode :: SExpr -> [SExpr] +scottDecode (Cons x y) = x : scottDecode y +scottDecode Nil = [] +scottDecode (AtomSymbol x) = [AtomSymbol x] +scottDecode (AtomInt x) = [AtomInt x] +scottDecode (AtomBool x) = [AtomBool x] +scottDecode (Quote x) = [Quote x] + +-- | Same as 'scottEncode' but for 'CallowSExpr' +scottEncode' :: [CallowSExpr] -> CallowSExpr +scottEncode' = dimap (map growUp) CallowSExpr scottEncode + + +makePrisms ''SExpr diff --git a/src/Maru/Type/TypeLevel.hs b/src/Maru/Type/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Maru/Type/TypeLevel.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Dependent types (Please see 'Maru.QQ') +module Maru.Type.TypeLevel + ( HighSExpr (..) + , Sing (..) + ) where + +import Data.Proxy (Proxy(..)) +import Data.Singletons (SingI(..), Sing, SingKind(..), SomeSing(..)) +import Data.Type.Bool (type (&&)) +import Data.Type.Equality (type (==)) +import GHC.TypeLits (Symbol, symbolVal, Nat, natVal, KnownSymbol, KnownNat) +import Maru.Type (SExpr(..), MaruSymbol(..)) +import qualified Data.Text as T + + +-- | A dependent type for 'SExpr' (Please see 'Maru.QQ.parse') +data HighSExpr = HCons HighSExpr HighSExpr + | HQuote HighSExpr + | HAtomInt Nat + | HAtomBool Bool + | HAtomSymbol Symbol + | HNil + + +data instance Sing (a :: HighSExpr) :: * where + HAtomSymbolS :: MaruSymbol -> Sing ('HAtomSymbol s) + HAtomBoolS :: Bool -> Sing ('HAtomBool x) + HAtomIntS :: Int -> Sing ('HAtomInt n) + HNilS :: Sing 'HNil + HQuoteS :: Sing x -> Sing ('HQuote x) + HConsS :: Sing x -> Sing y -> Sing ('HCons x y) + +instance SingI 'HNil where + sing :: Sing 'HNil + sing = HNilS + +instance KnownSymbol s => SingI ('HAtomSymbol s) where + sing :: Sing ('HAtomSymbol s) + sing = HAtomSymbolS . MaruSymbol . T.pack $ symbolVal (Proxy :: Proxy s) + +instance SingI ('HAtomBool 'True) where + sing :: Sing ('HAtomBool 'True) + sing = HAtomBoolS True + +instance SingI ('HAtomBool 'False) where + sing :: Sing ('HAtomBool 'False) + sing = HAtomBoolS False + +instance KnownNat n => SingI ('HAtomInt n) where + sing :: Sing ('HAtomInt n) + sing = HAtomIntS . fromInteger $ natVal (Proxy :: Proxy n) + +instance SingI x => SingI ('HQuote x) where + sing :: Sing ('HQuote x) + sing = let x' = sing :: Sing x + in HQuoteS x' + +instance (SingI x, SingI y) => SingI ('HCons x y) where + sing :: Sing ('HCons x y) + sing = let x' = sing :: Sing x + y' = sing :: Sing y + in HConsS x' y' + + +instance SingKind HighSExpr where + type DemoteRep HighSExpr = SExpr + fromSing HNilS = Nil + fromSing (HAtomSymbolS s) = AtomSymbol s + fromSing (HAtomBoolS x) = AtomBool x + fromSing (HAtomIntS n) = AtomInt n + fromSing (HQuoteS x) = Quote (fromSing x) + fromSing (HConsS x y) = Cons (fromSing x) (fromSing y) + toSing Nil = SomeSing HNilS + toSing (AtomSymbol s) = SomeSing $ HAtomSymbolS s + toSing (AtomBool x) = SomeSing $ HAtomBoolS x + toSing (AtomInt n) = SomeSing $ HAtomIntS n + toSing (Quote x) = case toSing x of + SomeSing x' -> SomeSing $ HQuoteS x' + toSing (Cons x y) = case (toSing x, toSing y) of + (SomeSing x', SomeSing y') -> SomeSing $ HConsS x' y' + + +type instance 'HNil == 'HNil = 'True +type instance 'HAtomInt x == 'HAtomInt y = x == y +type instance 'HAtomBool x == 'HAtomBool y = x == y +type instance 'HAtomSymbol x == 'HAtomSymbol y = x == y +type instance 'HQuote x == 'HQuote y = x == y +type instance 'HCons x1 y1 == 'HCons x2 y2 = x1 == x2 && y1 == y2 diff --git a/test/doctest/DocTest.hs b/test/doctest/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/doctest/DocTest.hs @@ -0,0 +1,20 @@ +import Test.DocTest (doctest) + +--TODO: Find all .hs in ./src, and doctest it + +main :: IO () +main = do + doctestIt "src" "src/Maru/Type/SExpr.hs" + [ "src/Maru/Parser.hs" + , "src/Maru/Preprocessor.hs" + , "src/Maru/Eval.hs" + , "src/Maru/Type/Eval.hs" + , "src/Maru/Type/TypeLevel.hs" + , "src/Maru/Eval/RuntimeOperation.hs" + , "src/Maru/QQ.hs" + ] + +doctestIt :: FilePath -> FilePath -> [FilePath] -> IO () +doctestIt baseDir path dependencies = do + let nico = "-i" ++ baseDir + doctest $ (nico:dependencies) ++ [path] diff --git a/test/tasty/Maru/Eval/FuncTest.hs b/test/tasty/Maru/Eval/FuncTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Maru/Eval/FuncTest.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Maru.Eval.FuncTest where + +import Control.Exception.Safe (SomeException) +import Maru.Type (SExpr(..), MaruEnv, SimplificationSteps) +import MaruTest (shouldBeEvaluatedTo) +import System.IO.Silently (silence) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=), Assertion, assertFailure) +import qualified Maru.Eval as Eval + +test_evaluator_calculates_pure_functions :: [TestTree] +test_evaluator_calculates_pure_functions = + [ testCase "(+ 2 3) to 5" $ + Cons (AtomSymbol "+") (Cons (AtomInt 2) (Cons (AtomInt 3) Nil)) + !?= AtomInt 5 + , testCase "(+ 2 (* 3 4)) to 14" $ + Cons (AtomSymbol "+") (Cons (AtomInt 2) (Cons (Cons (AtomSymbol "*") (Cons (AtomInt 3) (Cons (AtomInt 4) Nil))) Nil)) + !?= AtomInt 14 + , testCase "(+ 1 2 3) to 6" $ + Cons (AtomSymbol "+") (Cons (AtomInt 1) + (Cons (AtomInt 2) + (Cons (AtomInt 3) + Nil))) + !?= AtomInt 6 + ] + + +test_evaluator_evaluates_four_arith_operations :: [TestTree] +test_evaluator_evaluates_four_arith_operations = + [ testCase "`+` adds the tail numeric elements to the head numeric element" $ do + "(+ 1 2 3)" `shouldBeEvaluatedTo` "6" + "(+ 1)" `shouldBeEvaluatedTo` "1" + , testCase "`-` substracts the tail numeric elements from the head numeric element" $ do + "(- 10 2 3)" `shouldBeEvaluatedTo` "5" + "(- 0 2 3)" `shouldBeEvaluatedTo` "-5" + "(- 10)" `shouldBeEvaluatedTo` "-10" + , testCase "`*` adds the numeric element to itself the {element} times foldly" $ + "(* 2 3 4)" `shouldBeEvaluatedTo` "24" + , testCase "`/` gets the inverse value of the integral element foldly" $ do + "(/ 4 2 2)" `shouldBeEvaluatedTo` "1" + ] + + +(!?=) :: SExpr -> SExpr -> Assertion +origin !?= expected = do + result <- evalInitSilently origin + case result of + Left e -> assertFailure $ "An error is caught: " ++ show e + Right (actual, _, _) -> actual @?= expected + where + evalInitSilently :: SExpr -> IO (Either SomeException (SExpr, MaruEnv, SimplificationSteps)) + evalInitSilently = silence . Eval.eval Eval.initialEnv diff --git a/test/tasty/Maru/Eval/LiteralTest.hs b/test/tasty/Maru/Eval/LiteralTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Maru/Eval/LiteralTest.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Maru.Eval.LiteralTest where + +import MaruTest +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase) + + +test_boolean_literals :: [TestTree] +test_boolean_literals = + [ testCase "`true` literal is printable" $ do + "true" `shouldBeEvaluatedTo` "true" + "(def! x true)" `shouldBeEvaluatedTo` "true" + , testCase "`false` literal is printable" $ do + "false" `shouldBeEvaluatedTo` "false" + "(def! x false)" `shouldBeEvaluatedTo` "false" + ] + + +test_nil_literal :: [TestTree] +test_nil_literal = + [ testCase "`nil` is evaluated to `()`" $ + "nil" `shouldBeEvaluatedTo` "()" + ] + + +test_integral_positive_literals :: [TestTree] +test_integral_positive_literals = + [ testCase "can be evaluated" $ do + "+1" `shouldBeEvaluatedTo` "1" + "(+ +1 2)" `shouldBeEvaluatedTo` "3" + "(+ 2 +1)" `shouldBeEvaluatedTo` "3" + ] + +test_integral_negative_literals :: [TestTree] +test_integral_negative_literals = + [ testCase "can be evaluated" $ do + "-1" `shouldBeEvaluatedTo` "-1" + "(+ -1 2)" `shouldBeEvaluatedTo` "1" + "(+ 2 -1)" `shouldBeEvaluatedTo` "1" + ] diff --git a/test/tasty/Maru/Eval/MacroTest.hs b/test/tasty/Maru/Eval/MacroTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Maru/Eval/MacroTest.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Maru.Eval.MacroTest where + +import Data.Semigroup ((<>)) +import Data.String.QQ (s) +import Maru.Type (SExpr(..), MaruEnv, readable) +import MaruTest +import System.IO.Silently (capture_) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=), assertFailure) +import qualified Maru.Eval as E + + +-- | def! +test_defBang_macro :: [TestTree] +test_defBang_macro = + [ testCase "(`def!`) adds a value with a key to environment" $ do + (sexpr, env, _) <- runCodeInstantly "(def! *poi* 10)" + readable sexpr @?= "10" + (poi, _, _) <- runCode env "*poi*" + readable poi @?= "10" + ] + + +-- | let* +test_letStar_macro :: [TestTree] +test_letStar_macro = + [ testCase "(`let*`) adds a value with akey to new environment scope" $ + "(let* (x 10) x)" `shouldBeEvaluatedTo` "10" + , testCase "means the lexical scopes correctly" $ do + (sexpr, env, _) <- runCodeInstantly "(let* (x 10) x)" + -- the internal operation takes "x" well + readable sexpr @?= "10" + -- "x" cannot be gotten in the outer scope + "x" `isNotExistedIn` env + ] + + +-- | +-- e.g. (+ 1 2), *y* to be called by `call` +-- (regard that *y* is set) +test_call_macro :: [TestTree] +test_call_macro = + [ testCase "calls a first element of the list as a function/macro with tail elements implicitly" $ do + "(+ 1 2)" `shouldBeEvaluatedTo` "3" + (x, _, _) <- runCode modifiedEnv "*x*" + readable x @?= "10" + (y, _, _) <- runCode modifiedEnv "*y*" + readable y @?= "10" + , testCase "occurs an exception on (x) if x is neither a function nor a macro" $ do + point <- runCodeWithSteps E.initialEnv "(10)" + case point of + EvalError _ -> return () + x -> assertFailure $ "expected a `EvalError`, but got `" ++ show x ++ "`" + ] + where + -- initialEnv ∪ { (*x* := 10), (*x* := *x*) } + modifiedEnv :: MaruEnv + modifiedEnv = E.initialEnv <> + [[ ("*x*", AtomInt 10) + , ("*y*", AtomSymbol "*x*") + ]] + + +test_do_macro :: [TestTree] +test_do_macro = + [ testCase "evaluates taken arguments" $ do + (sexpr, env, _) <- runCodeInstantly $ "(do (def! x 10)" <> + "(def! y (+ x 1))" <> + "(def! z (+ y 1)))" + readable sexpr @?= "12" + "x" `isExistedIn` env + "y" `isExistedIn` env + "z" `isExistedIn` env + ] + + +test_if_macro :: [TestTree] +test_if_macro = + [ testCase "evaluates the third argument and returns the result, if the first argument is evaluated to `false` or `nil`" $ do + "(if false 0 1)" `shouldBeEvaluatedTo` "1" + "(if nil 0 3)" `shouldBeEvaluatedTo` "3" + + [ "(def! x false)" + ,"(if x 0 5)" + ] `shouldBeEvaluatedTo'` "5" + + [ "(def! x ())" + ,"(if x 0 7)" + ] `shouldBeEvaluatedTo'` "7" + + , testCase "evaluates the second argument and returns the result, if the first argument is evaluated to neither `false` nor `nil`" $ do + "(if true 1 0)" `shouldBeEvaluatedTo` "1" + "(if 0 5 0)" `shouldBeEvaluatedTo` "5" + "(if 10 7 0)" `shouldBeEvaluatedTo` "7" + + (_, env, _) <- runCodeInstantly "(def! x true)" + (sexpr, _, _) <- runCode env "(if x 9 0)" + sexpr @?= AtomInt 9 + ] + + +test_fn_macro :: [TestTree] +test_fn_macro = + [ testCase "can be applied with arguments" $ do + "((fn* (a) 10) 0)" `shouldBeEvaluatedTo` "10" -- an argument + "((fn* () 10))" `shouldBeEvaluatedTo` "10" -- zero arguments + "((fn* (x y z) y) 1 2 3)" `shouldBeEvaluatedTo` "2" -- multi arguments + + , testCase "can be bound as the variable" $ do + -- united + "(let* (f (fn* (x) x)) (f 10))" `shouldBeEvaluatedTo` "10" + -- devided + [ "(def! f (fn* (x) x))" + ,"(f 10)" + ] `shouldBeEvaluatedTo'` "10" + -- nested + runCorretly $ "(let* (x 10)" <> + "(let* (f (fn* (a) x))" <> + "(f 0)))" + + , testCase "can include the outer scopes variables (the behavior of closure)" $ + [ "(let* (x 10) (def! f (fn* (a) x)))" + , "(f 0)" + ] `shouldBeEvaluatedTo'` "10" + ] + + +test_print_macro :: [TestTree] +test_print_macro = + [ testCase "prints a S expression on the screen" $ do + captured <- capture_ $ runCodeInstantly "(print 10)" + captured @?= "10" + + captured <- capture_ $ runCodes E.initialEnv [ "(def! x 10)" + , "(print x)" + ] + captured @?= "10" + , testCase "prints S expressions on the screen" $ do + captured <- capture_ $ runCodeInstantly "(print 1 2 3)" + captured @?= "1\n2\n3" + , testCase "returns ()" $ + "(print 10)" `shouldBeEvaluatedTo` "()" + , testCase "prints nothing if anything are not taken" $ do + captured <- capture_ $ runCodeInstantly "(print)" + captured @?= "" + ] + + +test_list_macro :: [TestTree] +test_list_macro = + [ testCase "makes a list with the taken arguments" $ do + "(list)" `shouldBeEvaluatedTo` "()" + "(list 1 2 3)" `shouldBeEvaluatedTo` "(1 2 3)" + , testCase "evaluates each arguments" $ + "(list (+ 1 2) (+ 3 4))" `shouldBeEvaluatedTo` "(3 7)" + ] + + +test_quote_macro :: [TestTree] +test_quote_macro = + [ testCase "delays the evaluation" $ do + "(quote (1 2 3))" `shouldBeEvaluatedTo` "(1 2 3)" + "(quote (quote 2))" `shouldBeEvaluatedTo` "(quote 2)" + "(quote (10 (quote 20)))" `shouldBeEvaluatedTo` "(10 (quote 20))" + , testCase "can be meant by `'` prefix" $ do + "'(1 2 3)" `shouldBeEvaluatedTo` "(1 2 3)" + "''2" `shouldBeEvaluatedTo` "(quote 2)" + "'(10 '20)" `shouldBeEvaluatedTo` "(10 (quote 20))" + ] + + +test_this_macro :: [TestTree] +test_this_macro = + [ testCase "cab be called as a current function recursively" $ + [s| + ((fn (x) + (if (<= 0 x) + 0 + (+ x (this (- x 1))) + )) 5) + |] `shouldBeEvaluatedTo` "15" + , testCase "means a mostly inner if it nests" $ + [s| + ((fn (a) + ((fn (x) + (if (<= 0 x) + 0 + (this (- x 1)))) + (- a 1))) + 5) + |] `shouldBeEvaluatedTo` "10" + ] diff --git a/test/tasty/Maru/ParserTest.hs b/test/tasty/Maru/ParserTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Maru/ParserTest.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Maru.ParserTest where + +import Data.Text (Text) +import Maru.Parser (parse, parseErrorPretty) +import Maru.Preprocessor (preprocess) +import Maru.Type +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, assertFailure, (@?=), Assertion) +import qualified Maru.Type as MT + +test_parser_and_preprocessor_shows :: [TestTree] +test_parser_and_preprocessor_shows = + [ testCase "123 as 123" $ "123" `isShownAs` "123" + , testCase "abc as abc" $ "abc" `isShownAs` "abc" + , testCase "(123 456) as (123 456)" $ "(123 456)" `isShownAs` "(123 456)" + , testCase "( 123 456 789 ) as (123 456 789)" $ "( 123 456 789 )" `isShownAs` "(123 456 789)" + , testCase "( + 2 (* 3 4) ) as (+ 2 (* 3 4))" $ "( + 2 (* 3 4) )" `isShownAs` "(+ 2 (* 3 4))" + , testCase "(1 ) as (1)" $ "(1 )" `isShownAs` "(1)" + ] + where + isShownAs :: Text -> Text -> Assertion + isShownAs code expected = + case preprocess <$> parse code of + Left e -> assertFailure $ "A parse is failed: " ++ parseErrorPretty e + Right sexpr -> MT.readable sexpr @?= expected + + +test_parser_parses_quote_symbols :: [TestTree] +test_parser_parses_quote_symbols = + [ testCase "'{some} to `Quote' {some}`" $ do + parse "'1" @?= Right (Quote' (AtomInt' 1)) + parse "'a" @?= Right (Quote' (AtomSymbol' "a")) + parse "'(1 2)" @?= Right (Quote' (Cons' (AtomInt' 1) (Cons' (AtomInt' 2) Nil'))) + ] diff --git a/test/tasty/Maru/PreprocessorTest.hs b/test/tasty/Maru/PreprocessorTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Maru/PreprocessorTest.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Maru.PreprocessorTest where + +import Maru.Type +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) +import qualified Maru.Preprocessor as Pre + +test_preprocessor_fixes_quote_symbols :: [TestTree] +test_preprocessor_fixes_quote_symbols = + [ testCase "(e.g. 'Cons (AtomSymbol \"quote\") (Cons x Nil)') is preprocessed to 'Quote x'" $ do + let x = AtomInt 1 + x' = CallowSExpr x + Pre.preprocess (Cons' (AtomSymbol' "quote") (Cons' x' Nil')) @?= Quote x + let xs = Cons (AtomInt 1) (Cons (AtomInt 2) Nil) + xs' = CallowSExpr xs + Pre.preprocess (Cons' (AtomSymbol' "quote") (Cons' xs' Nil')) @?= Quote xs + ] + diff --git a/test/tasty/Maru/Type/EvalTest.hs b/test/tasty/Maru/Type/EvalTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Maru/Type/EvalTest.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedLabels #-} + +module Maru.Type.EvalTest where + +import Control.Monad.Fail (fail) +import Maru.Type.Eval (MaruCalculator, runMaruCalculator, throwFail) +import Prelude hiding (fail) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) +import qualified Data.Text as T + + +oops :: String +oops = "Oops xD" + + +test_maru_calculator_throws_the_exception_as_a_pure_value_by_fail :: [TestTree] +test_maru_calculator_throws_the_exception_as_a_pure_value_by_fail = + [ testCase "" $ + runMaruCalculator (negativeContext oops) + @?= runMaruCalculator (fail' oops) + ] + where + fail' :: String -> MaruCalculator () + fail' = throwFail . T.pack + + +-- | An alias of `fail` +negativeContext :: String -> MaruCalculator () +negativeContext = fail diff --git a/test/tasty/MaruTest.hs b/test/tasty/MaruTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/MaruTest.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The functions for help tests +module MaruTest + ( StoppedPoint (..) + , runCodeInstantly + , runCode + , runCodes + , runCodeWithSteps + , prettyAssertFailure + , shouldBeEvaluatedTo + , shouldBeEvaluatedTo' + , isExistedIn + , isNotExistedIn + , runCorretly + , runCodesCorrectly + ) where + +import Control.Lens (_1, _2, view, to, (<&>)) +import Control.Monad (void, (>=>)) +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) +import Maru.Type +import System.IO.Silently (silence) +import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) +import qualified Data.Text.IO as TIO +import qualified Maru.Eval as E +import qualified Maru.Parser as P +import qualified Maru.Preprocessor as Pr + +-- | +-- `ParseError` gives a cause of the parse error. +-- `EvalError` is same as `ParseError` but for the evaluation. +-- `Succeed` gives the results of the execution. +-- ("execution" means "parse" + "evaluate") +-- +-- Please see `runCodeWithSteps` for more information. +data StoppedPoint = ParseError String + | EvalError String + | Succeed SExpr MaruEnv SimplificationSteps + deriving (Show) + + +-- | +-- Similar to `runCode`. +-- Run maru's source code in new `MaruEnv`, +runCodeInstantly :: SourceCode -> IO (SExpr, MaruEnv, SimplificationSteps) +runCodeInstantly = runCode E.initialEnv + +-- | +-- Similar to `runCodeWithSteps`, +-- but `ParseError` and `EvalError` are thrown as the context of `IO` +runCode :: MaruEnv -> SourceCode -> IO (SExpr, MaruEnv, SimplificationSteps) +runCode env code = do + result <- runCodeWithSteps env code + case result of + EvalError msg -> fail msg + ParseError msg -> fail msg + Succeed x y z -> return (x, y, z) + +-- | +-- Similar to 'runCode', but multi expressions are taken. +-- And the previous result is continued. +runCodes :: MaruEnv -> NonEmpty SourceCode -> IO (SExpr, MaruEnv, SimplificationSteps) +runCodes env (code:|codes) = do + let runners = flip map codes $ \x -> flip runCode x . view _2 + let tailExecutor = foldl' (>=>) (flip runCode code . view _2) runners + runCode env "()" >>= tailExecutor + +-- | +-- Run maru's source code in the specified `MaruEnv`. +-- +-- If the parsing is failed, return `ParseError` . +-- If the evaluation is failed, return `EvalError`. +-- If all procedure is succeed, return `Succeed`. +runCodeWithSteps :: MaruEnv -> SourceCode -> IO StoppedPoint +runCodeWithSteps env code = do + result <- mapM (E.eval env . Pr.preprocess) $ P.parse code + case result of + Left e -> return . ParseError $ show e + Right (Left e) -> return . EvalError $ show e + Right (Right (x, y, z)) -> return $ Succeed x y z + +-- | +-- Pretty print the results, +-- and Make the failure this `Assertion` +prettyAssertFailure :: SExpr -> MaruEnv -> SimplificationSteps -> String -> Assertion +prettyAssertFailure sexpr env steps msg = do + putStrLn "Fail" + putStrLn msg + putStrLn $ "got output result: " ++ show sexpr + putStrLn $ "got final environment: " ++ show env + putStrLn "got logs:" + mapM_ TIO.putStrLn $ reportSteps steps + assertFailure "" + + +-- | 'code' can be evaluated to 'expected' +shouldBeEvaluatedTo :: SourceCode -> SourceCode -> Assertion +shouldBeEvaluatedTo code expected = do + (sexpr, _, _) <- runCodeInstantly code + readable sexpr @?= expected + +-- | Similar to 'shouldBeEvaluatedTo' (comparison) and 'runCodes' (multi codes) +shouldBeEvaluatedTo' :: NonEmpty SourceCode -> SourceCode -> Assertion +shouldBeEvaluatedTo' codes expected = do + actual <- silence $ runCodes E.initialEnv codes <&> view (_1 . to readable) + actual @?= expected + + +-- | 'var' is existed in 'env' +isExistedIn :: MaruSymbol -> MaruEnv -> Assertion +var `isExistedIn` env = void . runCode env $ unMaruSymbol var + +-- | 'var' is not existed in 'env' +isNotExistedIn :: MaruSymbol -> MaruEnv -> Assertion +var `isNotExistedIn` env = do + point <- runCodeWithSteps env $ unMaruSymbol var + case point of + EvalError _ -> return () + x -> assertFailure $ show x + + +-- | Mean that it returns something without the result +runCorretly :: Text -> Assertion +runCorretly = void . runCodeInstantly + +-- | Similar to 'runCorretly' and 'shouldBeEvaluatedTo'` +runCodesCorrectly :: NonEmpty Text -> Assertion +runCodesCorrectly = void . runCodes E.initialEnv diff --git a/test/tasty/Tasty.hs b/test/tasty/Tasty.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Tasty.hs @@ -0,0 +1,3 @@ +{-# + OPTIONS_GHC -F -pgmF tasty-discover +#-} diff --git a/zuramaru.cabal b/zuramaru.cabal new file mode 100644 --- /dev/null +++ b/zuramaru.cabal @@ -0,0 +1,197 @@ +-- This file has been generated from package.yaml by hpack version 0.18.1. +-- +-- see: https://github.com/sol/hpack + +name: zuramaru +version: 0.1.0.0 +synopsis: A lisp processor, An inline-lisp, in Haskell +description: A lisp dialect +category: Simple +homepage: https://github.com/aiya000/hs-zuramaru +author: aiya000 +maintainer: aiya000 +copyright: aiya000 +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +library + hs-source-dirs: + src + ghc-options: -Wall -Wno-name-shadowing -Wno-unused-do-bind -Wno-orphans -fprint-potential-instances -fprint-explicit-kinds + build-depends: + base >= 4.7 && < 5 + , cmdargs + , containers + , distributive + , either + , extensible + , extra + , lens + , megaparsec + , mono-traversable + , mtl + , profunctors + , readline + , safe + , safe-exceptions + , singletons + , string-qq + , template-haskell + , text + , text-show + , throwable-exceptions + , transformers + exposed-modules: + Maru.Eval + Maru.Eval.RuntimeOperation + Maru.Main + Maru.Parser + Maru.Preprocessor + Maru.QQ + Maru.QQ.ShortName + Maru.TH + Maru.Type + Maru.Type.Eval + Maru.Type.Parser + Maru.Type.SExpr + Maru.Type.TypeLevel + other-modules: + Paths_zuramaru + default-language: Haskell2010 + +executable maru + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -Wall -Wno-name-shadowing -Wno-unused-do-bind -Wno-orphans -fprint-potential-instances -fprint-explicit-kinds -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >= 4.7 && < 5 + , cmdargs + , containers + , distributive + , either + , extensible + , extra + , lens + , megaparsec + , mono-traversable + , mtl + , profunctors + , readline + , safe + , safe-exceptions + , singletons + , string-qq + , template-haskell + , text + , text-show + , throwable-exceptions + , transformers + , zuramaru + default-language: Haskell2010 + +test-suite integrate-test + type: exitcode-stdio-1.0 + main-is: Tasty.hs + hs-source-dirs: + test/tasty + src + ghc-options: -Wall -Wno-name-shadowing -Wno-unused-do-bind -Wno-orphans -fprint-potential-instances -fprint-explicit-kinds + build-depends: + base >= 4.7 && < 5 + , cmdargs + , containers + , distributive + , either + , extensible + , extra + , lens + , megaparsec + , mono-traversable + , mtl + , profunctors + , readline + , safe + , safe-exceptions + , singletons + , string-qq + , template-haskell + , text + , text-show + , throwable-exceptions + , transformers + , silently + , tasty + , tasty-discover + , tasty-hunit + other-modules: + Maru.Eval.FuncTest + Maru.Eval.LiteralTest + Maru.Eval.MacroTest + Maru.ParserTest + Maru.PreprocessorTest + Maru.Type.EvalTest + MaruTest + Maru.Eval + Maru.Eval.RuntimeOperation + Maru.Main + Maru.Parser + Maru.Preprocessor + Maru.QQ + Maru.QQ.ShortName + Maru.TH + Maru.Type + Maru.Type.Eval + Maru.Type.Parser + Maru.Type.SExpr + Maru.Type.TypeLevel + default-language: Haskell2010 + +test-suite unit-test + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: + test/doctest + src + ghc-options: -Wall -Wno-name-shadowing -Wno-unused-do-bind -Wno-orphans -fprint-potential-instances -fprint-explicit-kinds + build-depends: + base >= 4.7 && < 5 + , cmdargs + , containers + , distributive + , either + , extensible + , extra + , lens + , megaparsec + , mono-traversable + , mtl + , profunctors + , readline + , safe + , safe-exceptions + , singletons + , string-qq + , template-haskell + , text + , text-show + , throwable-exceptions + , transformers + , doctest + other-modules: + Maru.Eval + Maru.Eval.RuntimeOperation + Maru.Main + Maru.Parser + Maru.Preprocessor + Maru.QQ + Maru.QQ.ShortName + Maru.TH + Maru.Type + Maru.Type.Eval + Maru.Type.Parser + Maru.Type.SExpr + Maru.Type.TypeLevel + default-language: Haskell2010