├── .gitignore ├── README.md ├── demo.png ├── demoScript.txt └── mmaclone ├── LICENSE ├── app └── Main.hs ├── mmaclone.cabal ├── src ├── Data │ ├── Attribute.hs │ ├── DataType.hs │ ├── Environment │ │ ├── Environment.hs │ │ ├── EnvironmentType.hs │ │ └── Update.hs │ └── Number │ │ └── Number.hs ├── Eval │ ├── Eval.hs │ ├── EvalHead.hs │ ├── Patt │ │ ├── Pattern.hs │ │ ├── PatternPrimi.hs │ │ └── Regengine.hs │ └── Primitive │ │ ├── Arithmatic │ │ └── Arithmatic.hs │ │ ├── Compare │ │ └── Compare.hs │ │ ├── Control │ │ └── Branch.hs │ │ ├── Function │ │ └── Lambda.hs │ │ ├── IO │ │ └── Print.hs │ │ ├── InOut │ │ └── InOut.hs │ │ ├── List │ │ ├── Cons.hs │ │ ├── Elem.hs │ │ ├── Level.hs │ │ ├── List.hs │ │ ├── Map.hs │ │ └── Part.hs │ │ ├── Logic │ │ └── Logic.hs │ │ ├── Nest │ │ └── Nest.hs │ │ ├── PrimiFunc.hs │ │ ├── Primitives.hs │ │ ├── Replace │ │ ├── Replace.hs │ │ └── Unpack.hs │ │ └── Set │ │ └── Set.hs ├── Parser │ ├── NewParse.hs │ └── Trans.hs ├── Show │ └── Pretty.hs └── Test.hs ├── stack.yaml └── test ├── Data └── Number │ └── NumberSpec.hs ├── Eval └── EvalSpec.hs ├── Parser ├── NewParseSpec.hs └── TransSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work/ 17 | issue.txt 18 | *.db 19 | releasenote.md 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A simple term rewriting system with [Wolfram Language](https://www.wolfram.com/language/)'s syntax 2 | 3 | Inspired by the book [Write Yourself a Scheme in 48 Hours](https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours). 4 | I decide to write myself a simple interpreter of Wolfram Language to learn more about Haskell as well as 5 | achieve a deeper understanding about `Mathematica`, which is the desktop IDE for `Wolfram Language`. 6 | 7 | ## ScreenShot 8 | 9 | ![mmaclone](https://raw.githubusercontent.com/jyh1/mmaclone/master/demo.png) 10 | 11 | 12 | ## Running (Using [Stack](https://github.com/commercialhaskell/stack)) 13 | ``` 14 | git clone https://github.com/jyh1/mmaclone.git 15 | cd mmaclone/mmaclone 16 | stack setup 17 | stack build 18 | stack exec mmaclone-exe 19 | ``` 20 | Prebulid binary files are available on the [release page](https://github.com/jyh1/mmaclone/releases) 21 | 22 | ## Features 23 | This interpreter is intended to mimic every exact detail of `Wolfram Language`, including but not limited to its syntax, semantic, 24 | expression structure, evaluation details, etc. (All the scripts below were executed in the REPL session of the `mmaclone` program) 25 | 26 | 1. The program support nearly all `Wolfram Language`'s syntax sugar, infix operators as well as their precedence. E.g., inequality expression chain is parsed to the same AST with `Wolfram Language`. 27 | 28 | ``` 29 | In[1]:= FullForm[a==b>=c<=dz -> {x,z,y,k} 46 | In[2]:= {64, 44, 71, 48, 96, 47, 59, 71, 73, 51, 67, 50, 26, 49, 49}//.sortRule 47 | Out[2]= {26,44,47,48,49,49,50,51,59,64,67,71,71,73,96} 48 | (*Symbolic manipulation*) 49 | In[3]:= rules:={Log[x_ y_]:>Log[x]+Log[y],Log[x_^k_]:>k Log[x]} 50 | In[4]:= Log[a (b c^d)^e] //. rules 51 | Out[4]= Log[a]+e (Log[b]+d Log[c]) 52 | ``` 53 | Currently, the derivative function `D` is not built-in supported, but you could easily implement one with the powerful pattern matching facilities. 54 | ``` 55 | In[5]:= D[a_,x_]:=0 56 | In[6]:= D[x_,x_]:=1 57 | In[7]:= D[a_+b__,x_]:=D[a,x]+D[Plus[b],x] 58 | In[8]:= D[a_ b__,x_]:=D[a,x] b+a D[Times[b],x] 59 | In[9]:= D[a_^(b_), x_]:= a^b(D[b,x] Log[a]+D[a,x]/a b) 60 | In[10]:= D[Log[a_], x_]:= D[a, x]/a 61 | In[11]:= D[Sin[a_], x_]:= D[a,x] Cos[a] 62 | In[12]:= D[Cos[a_], x_]:=-D[a,x] Sin[a] 63 | (*performing derivative*) 64 | In[13]:= D[Sin[x]/x,x] 65 | Out[13]= -x^(-2) Sin[x]+Cos[x] x^(-1) 66 | In[14]:= D[%,x] 67 | Out[14]= -Cos[x] x^(-2)-(-2 x^(-3) Sin[x]+Cos[x] x^(-2))-x^(-1) Sin[x] 68 | ``` 69 | Pattern test facility is of the same semantic with `Wolfram Language`'s. 70 | ``` 71 | In[15]:= {{1,1},{0,0},{0,2}}/.{x_,x_}/;x+x==2 -> a 72 | Out[15]= {a,{0,0},{0,2}} 73 | In[16]:= {a, b, c, d, a, b, b, b} /. a | b -> x 74 | Out[16]= {x,x,c,d,x,x,x,x} 75 | In[17]:= g[a_*b__]:=g[a]+g[Times[b]] 76 | In[18]:= g[x y z k l] 77 | Out[18]= g[k]+g[l]+g[x]+g[y]+g[z] 78 | In[19]:= q[i_,j_]:=q[i,j]=q[i-1,j]+q[i,j-1];q[i_,j_]/;i<0||j<0=0;q[0,0]=1;Null 79 | In[20]:= q[5,5] 80 | Out[20]= 252 81 | ``` 82 | 3. Some more interesting scripts 83 | 84 | ``` 85 | In[1]:= ((#+##&) @@#&) /@{{1,2},{2,2,2},{3,4}} 86 | Out[1]= {4,8,10} 87 | In[2]:= fib[n_]:=fib[n]=fib[n-1]+fib[n-2];fib[1]=fib[2]=1;Null 88 | In[3]:= fib[100] 89 | Out[3]= 354224848179261915075 90 | In[4]:= fib[1000000000000] 91 | Iteration Limit exceeded, try to increase $IterationLimit 92 | In[5]:= Print/@fib/@{10,100} 93 | 55 94 | 354224848179261915075 95 | Out[5]= {Null,Null} 96 | ``` 97 | 98 | ## More 99 | 100 | For more information please refer to the project [wiki](https://github.com/jyh1/mmaclone/wiki) (still under construction). 101 | 102 | 103 | 104 | ## Features that are likely to be added in future versions: 105 | (Some serious design errors are exposed during development, which I consider are inhibiting 106 | the project from scaling up. So currently my primary focus would be on refactor 107 | rather than adding new features/functions) 108 | 109 | 1. More mathematical functions (`Sin`, `Cos`, `Mod` etc...) 110 | 2. Arbitrary precision floating arithmetic using GMP(GNU Multiple Precision Arithmetic Library), currently arbitrary integer, double and rational number are supported. 111 | 2. More built-in functions (`Level`, `Import`, `Derivative`etc...) 112 | 3. More sophisticated pattern matching 113 | * ~~head specification (of the form Blank[*Head*], currently it only support list type)~~(Implemented) 114 | * ~~Pattern Test~~(Implemented) 115 | * ~~BlankSequence, BlankNullSequence~~(Implemented) 116 | * Other pattern matching expression, like `Verbatim`, `Longest` 117 | 4. ~~RecursionLimit~~(Implemented) 118 | 5. Negative index e.g. in `Part` 119 | 6. Negative level specification 120 | 7. Curried function e.g. `f[a][b]` (currently it will throw an error if one is trying to attach value to 121 | the curried form through `Set` or `SetDelayed`) 122 | 8. Use iPython as front end 123 | 9. ~~Replace String implementation with more efficient Text~~(Implemented) 124 | -------------------------------------------------------------------------------- /demo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyh1/mmaclone/0a8864681ecb77b68b106e728e185632dc60847d/demo.png -------------------------------------------------------------------------------- /demoScript.txt: -------------------------------------------------------------------------------- 1 | sortRule := {x___,y_,z_,k___}/;y>z -> {x,z,y,k} 2 | {64, 44, 71, 48, 96, 47, 59, 71, 73, 51, 67, 50, 26, 49, 49}//.sortRule 3 | {{1,1},{0,0},{0,2}}/.{x_,x_}/;x+x==2 -> a 4 | rules:={Log[x_ y_]:>Log[x]+Log[y],Log[x_^k_]:>k Log[x]} 5 | Log[a (b c^d)^e] //. rules 6 | fib[n_]:=fib[n]=fib[n-1]+fib[n-2];fib[0]=fib[1]=1;Null 7 | Print/@fib/@{10,100} 8 | ({#,Plus[##2]}&) @@@(Range/@Range[2,10]) 9 | %[[Range[1,9,2],2]] 10 | 11 | (If[#==0,1,# #0[#-1]]&)/@NestList[(2 #)&,5,2] 12 | 13 | Map[fib,Range/@Range[10],{2}] 14 | Print/@fib/@{10,100} 15 | ({#,Plus[##2]}&) @@@(Range/@Range[2,10]) 16 | %[[Range[1,9,2],2]] 17 | 18 | D[a_,x_]=0 19 | D[x_,x_]:=1 20 | D[a_+b__,x_]:=D[a,x]+D[Plus[b],x] 21 | D[a_ b__,x_]:=D[a,x] b+a D[Times[b],x] 22 | D[a_^(b_), x_]:= a^b(D[b,x] Log[a]+D[a,x]/a b) 23 | D[Log[a_], x_]:= D[a, x]/a 24 | D[Sin[a_], x_]:= D[a,x] Cos[a] 25 | D[Cos[a_], x_]:=-D[a,x] Sin[a] 26 | Nest[D[#,x]&,x/Sin[x],5] 27 | 28 | {x___?(#<2&),y_,z___} -> {Length[{x}],y} 29 | -------------------------------------------------------------------------------- /mmaclone/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Yonghao Jin (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /mmaclone/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | import Control.Monad 4 | import Control.Monad.Except 5 | import Text.Printf 6 | import System.IO 7 | import Control.Monad.Trans.State 8 | 9 | import Data.DataType 10 | import Data.Environment.Environment 11 | import Data.Environment.EnvironmentType 12 | import Eval.Eval 13 | import Eval.Primitive.PrimiFunc 14 | import Parser.Trans 15 | import Show.Pretty 16 | 17 | import Control.Lens 18 | import qualified Data.Text as T 19 | import qualified Data.Text.IO as T 20 | import System.Console.Haskeline 21 | 22 | 23 | info :: T.Text 24 | info = T.unlines ["A simple Mathmatica clone (v0.1.0)", 25 | "Copyright Yonghao Jin (c) 2016.", 26 | "Feel free to contact me via jyh1@mail.ustc.edu.cn"] 27 | 28 | 29 | main :: IO() 30 | main = do 31 | T.putStrLn info 32 | runInputT defaultSettings (loop initialState) 33 | 34 | 35 | loop :: PrimiEnv -> InputT IO () 36 | loop env = 37 | let cl = env ^. line in 38 | do 39 | input <- getInputLine (printf "In[%d]:= " cl :: String) 40 | case input of 41 | Just input -> 42 | repl env input 43 | Nothing -> return () 44 | 45 | 46 | 47 | repl :: PrimiEnv -> String -> InputT IO () 48 | repl env input = do 49 | res <- lift (runExceptT $ runStateT (evaluateExpression input) env) 50 | case res of 51 | Right (ans, newEnv) -> 52 | let ncl = newEnv ^. line in 53 | do 54 | when (ans /= "") $ outputStrLn ans 55 | loop newEnv 56 | Left err -> do 57 | outputStrLn (show err) 58 | loop env 59 | 60 | 61 | 62 | type Repl = InputT (StateT PrimiEnv IOThrowsError) () 63 | 64 | getExpr :: String -> IOThrowsError LispVal 65 | getExpr string = 66 | liftThrows (readExpr string) 67 | 68 | 69 | evaluateExpression :: String -> StateResult String 70 | evaluateExpression str = do 71 | expr <- lift (getExpr str) 72 | res <- evalWithRecord expr 73 | new <- getLineNumber 74 | line += 1 75 | return (report new res) 76 | 77 | 78 | report :: Int -> LispVal -> String 79 | report _ (Atom "Null") = "" 80 | report n val = printf "Out[%d]= " n ++ T.unpack (showLispVal val) 81 | -------------------------------------------------------------------------------- /mmaclone/mmaclone.cabal: -------------------------------------------------------------------------------- 1 | name: mmaclone 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: http://github.com/githubuser/mmaclone#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Yonghao Jin 9 | maintainer: jyh1@mail.ustc.edu.cn 10 | copyright: 2016 Y. Jin 11 | category: None 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Test 19 | , Parser.Trans 20 | , Parser.NewParse 21 | , Eval.Eval 22 | , Eval.EvalHead 23 | , Data.DataType 24 | , Data.Number.Number 25 | , Data.Environment.Environment 26 | , Data.Environment.EnvironmentType 27 | , Data.Environment.Update 28 | , Data.Attribute 29 | , Eval.Patt.Pattern 30 | , Eval.Patt.PatternPrimi 31 | , Eval.Patt.Regengine 32 | -- , Eval.Primitive.PrimiType 33 | , Eval.Primitive.Primitives 34 | , Eval.Primitive.PrimiFunc 35 | , Eval.Primitive.Arithmatic.Arithmatic 36 | , Eval.Primitive.Compare.Compare 37 | , Eval.Primitive.List.List 38 | , Eval.Primitive.List.Elem 39 | , Eval.Primitive.List.Part 40 | , Eval.Primitive.List.Cons 41 | , Eval.Primitive.List.Map 42 | , Eval.Primitive.List.Level 43 | , Eval.Primitive.Control.Branch 44 | , Eval.Primitive.Logic.Logic 45 | , Eval.Primitive.Function.Lambda 46 | , Eval.Primitive.Replace.Replace 47 | , Eval.Primitive.Replace.Unpack 48 | , Eval.Primitive.Nest.Nest 49 | , Eval.Primitive.Set.Set 50 | , Eval.Primitive.IO.Print 51 | , Eval.Primitive.InOut.InOut 52 | 53 | , Show.Pretty 54 | build-depends: base >= 4.7 && < 5 55 | , mtl 56 | , containers 57 | , transformers 58 | , parsec 59 | , lens 60 | , hspec 61 | , QuickCheck 62 | , text 63 | default-language: Haskell2010 64 | extensions: OverloadedStrings 65 | 66 | executable mmaclone-exe 67 | hs-source-dirs: app 68 | main-is: Main.hs 69 | ghc-options: -threaded -rtsopts -with-rtsopts=-N1 70 | build-depends: base 71 | , mtl 72 | , transformers 73 | , mmaclone 74 | , lens 75 | , text 76 | , haskeline 77 | default-language: Haskell2010 78 | 79 | test-suite mmaclone-test 80 | type: exitcode-stdio-1.0 81 | hs-source-dirs: test 82 | main-is: Spec.hs 83 | build-depends: base 84 | , mmaclone 85 | , hspec 86 | , QuickCheck 87 | , mtl 88 | , parsec 89 | , transformers 90 | , text 91 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 92 | default-language: Haskell2010 93 | extensions: OverloadedStrings 94 | 95 | source-repository head 96 | type: git 97 | location: https://github.com/jyh1/mmaclone 98 | -------------------------------------------------------------------------------- /mmaclone/src/Data/Attribute.hs: -------------------------------------------------------------------------------- 1 | module Data.Attribute where 2 | import Data.DataType 3 | 4 | import qualified Data.Map.Strict as M 5 | import Data.Maybe 6 | import Data.List(sort) 7 | import qualified Data.Text as T 8 | -- import Data.List 9 | -- attributes 10 | data Attribute = HoldAll 11 | | HoldFirst 12 | | HoldRest 13 | | Orderless 14 | | Flatten 15 | | SequenceHold 16 | | OneIdentity 17 | deriving (Show,Eq) 18 | type Attributes = M.Map T.Text [Attribute] 19 | 20 | plusAttr :: [Attribute] 21 | plusAttr = [Orderless, Flatten,OneIdentity] 22 | 23 | attributes :: Attributes 24 | attributes = M.fromList[ 25 | ("Plus", plusAttr), 26 | ("Times", plusAttr), 27 | ("Hold", [HoldAll]), 28 | ("Set", [HoldFirst,SequenceHold]), 29 | ("SetDelayed", [HoldAll,SequenceHold]), 30 | ("If", [HoldRest]), 31 | ("And",[HoldAll,OneIdentity]), 32 | ("Or",[HoldAll,OneIdentity]), 33 | ("Function", [HoldAll]), 34 | ("RuleDelayed",[HoldRest,SequenceHold]), 35 | ("Condition", [HoldAll]), 36 | ("Pattern", [HoldFirst]) 37 | ] 38 | 39 | lookUpAttribute :: T.Text -> Attributes -> [Attribute] 40 | lookUpAttribute name att = fromMaybe [] (M.lookup name att) 41 | 42 | getAttributes :: LispVal -> Attributes -> [Attribute] 43 | getAttributes (Atom name) att = lookUpAttribute name att 44 | getAttributes _ _ = [] 45 | 46 | 47 | -- attribute eval----------------------------------------- 48 | 49 | allAttr :: [Attribute] -> LispVal-> [LispVal] -> [LispVal] 50 | allAttr att h = attEvalOrderless att .attEvalFlatten att h . 51 | attEvalSeqHold att 52 | 53 | attEvalOrderless :: [Attribute] -> [LispVal] -> [LispVal] 54 | attEvalOrderless att vals 55 | | Orderless `elem` att = sort vals 56 | | otherwise = vals 57 | 58 | attEvalFlatten :: [Attribute] -> LispVal -> [LispVal] -> [LispVal] 59 | attEvalFlatten att h vals 60 | | Flatten `elem` att = deleteSameHead vals h 61 | | otherwise = vals 62 | 63 | attEvalSeqHold :: [Attribute] -> [LispVal] -> [LispVal] 64 | attEvalSeqHold att vals 65 | | SequenceHold `elem` att = vals 66 | | otherwise = deleteSameHead vals (Atom "Sequence") 67 | 68 | -- ------------------------------------------------ 69 | attributeTransform :: Attributes -> LispVal -> LispVal 70 | attributeTransform att (List lis@(h:rest)) = 71 | let attrs = getAttributes h att in 72 | attTransOneIdent attrs lis 73 | attributeTransform _ val = val 74 | 75 | attTransOneIdent :: [Attribute] -> [LispVal] -> LispVal 76 | attTransOneIdent att lis 77 | | OneIdentity `elem` att && length lis == 2 = lis !! 1 78 | | otherwise = List lis 79 | -------------------------------------------------------------------------------- /mmaclone/src/Data/DataType.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE ExistentialQuantification #-} 2 | {-#LANGUAGE FlexibleInstances #-} 3 | {-#LANGUAGE FlexibleContexts #-} 4 | module Data.DataType where 5 | 6 | import Control.Monad.Except 7 | -- import Data.IORef 8 | import qualified Data.Map.Strict as M 9 | import Control.Monad.Trans.Except 10 | import Text.ParserCombinators.Parsec(ParseError) 11 | import Data.List 12 | import Data.Number.Number 13 | import qualified Data.Text as T 14 | import Text.Printf 15 | 16 | -- * Module containing all foundamental types and functions 17 | -- ** LispVal 18 | data LispVal = 19 | Number Number 20 | | String T.Text 21 | | Atom T.Text 22 | | List [LispVal] 23 | | Char Char 24 | deriving(Eq, Ord) 25 | 26 | type IOThrowsError = ExceptT LispError IO 27 | -- type LispFun = LispVal -> IOThrowsError LispVal 28 | 29 | instance Show LispVal where 30 | show = T.unpack . fullForm 31 | 32 | isNull :: LispVal -> Bool 33 | isNull (Atom "Null") = True 34 | isNull _ = False 35 | 36 | atomNull = Atom "Null" 37 | 38 | atomLine = Atom "$Line" 39 | 40 | atomLimit = Atom "$IterationLimit" 41 | 42 | atomIn = Atom "In" 43 | atomOut = Atom "Out" 44 | 45 | isBool (Atom "True") = True 46 | isBool (Atom "False") = True 47 | isBool _ = False 48 | 49 | true = toBool True 50 | false = toBool False 51 | 52 | trueQ (Atom "True") = True 53 | trueQ _ = False 54 | 55 | toBool True = Atom "True" 56 | toBool False = Atom "False" 57 | unBool (Atom "True") = True 58 | unBool (Atom "False") = False 59 | 60 | list ls = List $ Atom "List" : ls 61 | 62 | tshow :: (Show s) => s -> T.Text 63 | tshow = T.pack . show 64 | 65 | fullForm :: LispVal -> T.Text 66 | fullForm (Atom s) = s 67 | fullForm (List []) = "" 68 | fullForm (List (l:ls)) = 69 | T.concat [fullForm l, "[", T.intercalate "," (map fullForm ls), "]"] 70 | fullForm (Number i) = tshow i 71 | fullForm (String s) = s 72 | fullForm (Char c) = tshow c 73 | -- fullForm (Char c) = show c 74 | 75 | data Unpacker = forall a. Ord a => Unpacker (LispVal -> ThrowsError a) 76 | 77 | -- data EqUnpacker = forall a. Eq a => EqUnpacker (LispVal -> ThrowsError a) 78 | 79 | -- unpackNum' :: LispVal -> ThrowsError Number 80 | unpackNum' (Number n) = return n 81 | unpackNum' x = throwError $ TypeMismatch "number" x 82 | 83 | unpackString' :: LispVal -> ThrowsError T.Text 84 | unpackString' (String s) = return s 85 | unpackString' x = throwError $ TypeMismatch "string" x 86 | 87 | unpackChar' :: LispVal -> ThrowsError Char 88 | unpackChar' (Char s) = return s 89 | unpackChar' x = throwError $ TypeMismatch "string" x 90 | 91 | unpackBool' :: LispVal -> ThrowsError Bool 92 | unpackBool' (Atom "True") = return True 93 | unpackBool' (Atom "False") = return False 94 | unpackBool' x = throwError $ TypeMismatch "string" x 95 | 96 | unpackers :: [Unpacker] 97 | unpackers = [Unpacker unpackNum', Unpacker unpackString', 98 | Unpacker unpackChar', 99 | Unpacker unpackBool'] 100 | 101 | checkNum :: LispVal -> Bool 102 | checkNum (Number _) = True 103 | checkNum _ = False 104 | 105 | unpackNum :: LispVal -> Number 106 | unpackNum = extractValue . unpackNum' 107 | 108 | integer :: (Integral a) => a -> LispVal 109 | integer = Number . Integer . fromIntegral 110 | 111 | double :: Double -> LispVal 112 | double = Number . Double 113 | -- ------------------------------------------ 114 | 115 | -- LispError 116 | 117 | data LispError = NumArgs T.Text Int Int 118 | | NumArgsMore T.Text Int Int 119 | | NumArgsBetween T.Text Int Int Int 120 | | TypeMismatch T.Text LispVal 121 | | Parser ParseError 122 | | BadSpecialForm T.Text LispVal 123 | | NotFunction T.Text T.Text 124 | | UnboundVar T.Text T.Text 125 | | Default T.Text 126 | | PartE T.Text LispVal 127 | | Incomplete [LispVal] 128 | | SetError LispVal 129 | | Level LispVal 130 | | SlotError LispVal 131 | | LimitExceed 132 | 133 | 134 | instance Show LispError where 135 | show = T.unpack . lispErrorToText 136 | 137 | lispErrorToText :: LispError -> T.Text 138 | lispErrorToText (UnboundVar message varname) = T.concat [message, ": ", varname] 139 | lispErrorToText (BadSpecialForm message form) = T.concat [message, ": ", fullForm form] 140 | lispErrorToText (NotFunction message func) = T.concat [message, ": ", func] 141 | lispErrorToText (NumArgs name expected found) = T.pack (printf "%s is called with %d arguments, %d arguments are expected" name found expected) 142 | lispErrorToText (NumArgsMore name botom found) = T.pack (printf "%s is called with %d arguments, %d or more arguments are expected" name found botom) 143 | lispErrorToText (NumArgsBetween name l r found) = T.pack(printf "%s is called with %d arguments, between %d and %d arguments are exprected" name found l r) 144 | lispErrorToText (TypeMismatch expected found) = T.concat ["Invalid type: expected ", expected, 145 | ", found", fullForm found] 146 | lispErrorToText (Parser parseErr) = T.concat ["Parse error at ", tshow parseErr] 147 | 148 | lispErrorToText (Incomplete s) = T.concat [fullForm (List s), "is incomplete.More input is needed"] 149 | lispErrorToText (PartE tag v) = T.concat [fullForm v, " ", tag] 150 | lispErrorToText (Default s) = s 151 | lispErrorToText (SetError v) = T.concat ["Cannot assign to object ", fullForm v] 152 | lispErrorToText (Level v) = T.concat [fullForm v, " is not a valid level specification"] 153 | lispErrorToText (SlotError s) = T.pack (printf "%s cannot be fully filled" (fullForm s)) 154 | lispErrorToText LimitExceed = "Iteration Limit exceeded, try to increase $IterationLimit" 155 | 156 | type ThrowsError = Either LispError 157 | 158 | plusError :: ThrowsError a -> ThrowsError a -> ThrowsError a 159 | plusError (Left _) l = l 160 | plusError a _ = a 161 | 162 | sumError :: [ThrowsError a] -> ThrowsError a 163 | sumError = foldr plusError (Left (Default "mzero")) 164 | 165 | 166 | trapError action = catchError action (return . show) 167 | 168 | extractValue :: ThrowsError a -> a 169 | extractValue (Right val) = val 170 | 171 | -- -------------------------------------------------- 172 | 173 | liftThrows :: ThrowsError a -> IOThrowsError a 174 | liftThrows (Left err) = throwError err 175 | liftThrows (Right val) = return val 176 | 177 | -- --------------------------------- 178 | wrapSequence :: [LispVal] -> LispVal 179 | wrapSequence xs = List (Atom "Sequence": xs) 180 | 181 | applyHead,changeHead,addHead :: LispVal -> LispVal -> LispVal 182 | applyHead h args = List [h,args] 183 | 184 | changeHead h (List (l:ls)) = List (h:ls) 185 | changeHead _ val = val 186 | 187 | addHead h (List ls) = List (h:ls) 188 | addHead _ _ = error "DataType.addHead :: Non list" 189 | 190 | sortList :: LispVal -> LispVal 191 | sortList (List (x:xs)) = List (x: sort xs) 192 | sortList val = val 193 | 194 | deleteSameHead :: [LispVal] -> LispVal -> [LispVal] 195 | deleteSameHead [] _ = [] 196 | deleteSameHead (val@(List x):xs) h 197 | | head x == h = tail x ++ deleteSameHead xs h 198 | | otherwise = val : deleteSameHead xs h 199 | deleteSameHead (x:xs) h = x : deleteSameHead xs h 200 | 201 | unpackInt _ (Number (Integer n)) = return $ fromIntegral n 202 | unpackInt err _ = throwError err 203 | 204 | unpackIntWithThre thre err n = do 205 | n' <- unpackInt err n 206 | if n' < thre then throwError err else return n' 207 | 208 | unpackAtom (Atom name) = name 209 | unpackAtom _ = error "Data.DataType unpackAtom" 210 | -- ---------------------------------------------- 211 | -------------------------------------------------------------------------------- /mmaclone/src/Data/Environment/Environment.hs: -------------------------------------------------------------------------------- 1 | module Data.Environment.Environment where 2 | 3 | import Data.DataType 4 | import Eval.Patt.Pattern 5 | import Eval.Patt.PatternPrimi 6 | import Data.Environment.EnvironmentType 7 | 8 | 9 | import Control.Monad.Except 10 | import qualified Data.Map.Strict as M 11 | import Control.Monad.Trans.Except 12 | import Control.Lens hiding (Context,List) 13 | import Data.Maybe 14 | import qualified Data.Text as T 15 | 16 | 17 | emptyOwnValue :: OwnValue 18 | emptyOwnValue = M.fromList [("$IterationLimit", Number 50000)] 19 | emptyDownValue :: DownValue 20 | emptyDownValue = M.empty 21 | 22 | emptyDown :: Down 23 | emptyDown = Down M.empty [] 24 | 25 | nullContext :: Context 26 | nullContext = Context emptyOwnValue emptyDownValue 27 | 28 | -- readCont :: Env -> IOThrowsError Context 29 | -- readCont = liftIO . readIORef 30 | 31 | mergePatt :: PatternRule -> PatternRule -> PatternRule 32 | mergePatt = (++) 33 | addPatt = (:) 34 | 35 | insertPattern :: [LispVal] -> LispVal -> Down -> Down 36 | insertPattern lhs rhs downV = 37 | pattern %~ addPatt (List lhs,rhs) $ downV 38 | 39 | insertValue :: [LispVal] -> LispVal -> Down -> Down 40 | insertValue lhs rhs downV = 41 | value %~ M.insert (List lhs) rhs $ downV 42 | 43 | updateDown :: [LispVal] -> LispVal ->Down -> Down 44 | updateDown lhs 45 | | isPattern (List lhs) = insertPattern lhs 46 | | otherwise = insertValue lhs 47 | 48 | updateDownValue :: LispVal -> LispVal -> DownValue -> DownValue 49 | updateDownValue val rhs = 50 | let 51 | name = getSetName val 52 | List lhs = getLhs val 53 | initial = updateDown lhs rhs emptyDown 54 | update = const (updateDown lhs rhs) 55 | in 56 | M.insertWith update name initial 57 | 58 | updateContext :: LispVal -> LispVal -> Context -> Context 59 | updateContext (Atom name) rhs = 60 | own %~ M.insert name rhs 61 | updateContext val@(List _) rhs = 62 | down %~ updateDownValue val rhs 63 | 64 | 65 | validSet :: LispVal -> Bool 66 | validSet (List [(Atom "Condition"), p, _]) = validSet p 67 | validSet (List ((Atom "Condition"):_)) = False 68 | validSet (List (Atom _ : _)) = True 69 | validSet (Atom _) = True 70 | validSet _ = False 71 | 72 | replaceDown :: Down -> LispVal -> ReplaceResult 73 | replaceDown downV lhs = 74 | let patt = downV ^. pattern.to (replaceRuleList lhs)-- (msum . map (replace lhs)) 75 | val = downV ^. value.to (M.lookup lhs) in 76 | case val of 77 | Nothing -> patt 78 | just -> return just 79 | 80 | getSetName :: LispVal -> T.Text 81 | getSetName (List (Atom "Condition":p:_)) = getSetName p 82 | getSetName (List (Atom name:_)) = name 83 | 84 | getLhs :: LispVal -> LispVal 85 | getLhs (List [Atom "Condition", p, t]) = 86 | List [Atom "Condition", getLhs p, t] 87 | getLhs (List (Atom _: lhs)) = List lhs 88 | 89 | unpackLhs :: LispVal -> (T.Text, LispVal) 90 | unpackLhs val = (getSetName val, getLhs val) 91 | 92 | replaceDownValue :: LispVal -> DownValue -> Primi 93 | -- replaceDownValue val@(List (Atom name : lhs)) downVal = 94 | replaceDownValue val downVal = 95 | let name = getSetName val 96 | lhs = getLhs val in 97 | liftM (fromMaybe val) $ do 98 | let downV = M.lookup name downVal 99 | case downV of 100 | Nothing -> return Nothing 101 | Just downV' -> replaceDown downV' lhs 102 | 103 | replaceOwnValue :: LispVal -> OwnValue -> LispVal 104 | replaceOwnValue val@(Atom name) ownVal = 105 | fromMaybe val $ M.lookup name ownVal 106 | 107 | replaceContext :: LispVal -> Context -> Primi 108 | replaceContext val@(Atom _) con = 109 | return $ con ^.own.to (replaceOwnValue val) 110 | replaceContext val@(List _) con = 111 | con ^. down.to (replaceDownValue val) 112 | -------------------------------------------------------------------------------- /mmaclone/src/Data/Environment/EnvironmentType.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE TemplateHaskell#-} 2 | module Data.Environment.EnvironmentType where 3 | 4 | import Data.DataType 5 | 6 | 7 | import qualified Data.Map.Strict as M 8 | import Control.Lens hiding (Context,List) 9 | import qualified Data.Text as T 10 | import Control.Monad.Trans.State 11 | 12 | 13 | 14 | type ValueRule = M.Map LispVal LispVal 15 | type PatternRule = [(LispVal, LispVal)] 16 | type OwnValue = M.Map T.Text LispVal 17 | type DownValue = M.Map T.Text Down 18 | data Down = Down {_value :: ValueRule,_pattern :: PatternRule} 19 | data Context = Context {_own :: OwnValue, _down :: DownValue} 20 | 21 | makeLenses ''Down 22 | makeLenses ''Context 23 | 24 | 25 | 26 | -- * Types and common functions for defining primitive functions. 27 | 28 | type Result = ThrowsError (Maybe LispVal) 29 | type IOResult = IOThrowsError (Maybe LispVal) 30 | 31 | type EvalResult = IOThrowsError LispVal 32 | 33 | type StateResult a = StateT PrimiEnv IOThrowsError a 34 | 35 | -- | Basic primitive function which only perform simple term rewriting 36 | type Primi = StateResult LispVal 37 | 38 | type Eval = LispVal -> Primi 39 | 40 | type Primitives = M.Map T.Text Primi 41 | 42 | type EvalArguments = [LispVal] -> Primi 43 | 44 | 45 | -- | Envrionment for primitive function 46 | data PrimiEnv = PrimiEnv 47 | { _eval :: Eval 48 | , _con :: Context 49 | , _args :: [LispVal] 50 | -- , _modified :: Bool 51 | , _dep :: Int 52 | , _line :: Int 53 | } 54 | 55 | makeLenses ''PrimiEnv 56 | 57 | 58 | -- Pattern matching types 59 | type Pattern = LispVal 60 | type Matched = (T.Text, LispVal) 61 | type MatchRes = M.Map T.Text LispVal 62 | initialMatch = M.empty 63 | 64 | 65 | type Rule = (Pattern, LispVal) 66 | type Rules = [Rule] 67 | 68 | type MaybeMatch = Maybe MatchRes 69 | type MatchResult = StateResult MaybeMatch 70 | type ReplaceResult = StateResult (Maybe LispVal) 71 | -------------------------------------------------------------------------------- /mmaclone/src/Data/Environment/Update.hs: -------------------------------------------------------------------------------- 1 | module Data.Environment.Update where 2 | 3 | import Data.DataType 4 | import Data.Environment.Environment 5 | import Data.Environment.EnvironmentType 6 | import Eval.Primitive.PrimiFunc 7 | 8 | import Control.Lens hiding(List, Context) 9 | 10 | setVariable :: LispVal -> LispVal -> StateResult () 11 | setVariable lhs rhs = updateCon (updateContext lhs rhs) 12 | 13 | getVariable :: LispVal -> Primi 14 | getVariable lhs = do 15 | context <- use con 16 | replaceContext lhs context 17 | -------------------------------------------------------------------------------- /mmaclone/src/Data/Number/Number.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE ExistentialQuantification, RankNTypes #-} 2 | module Data.Number.Number 3 | (Number(..), powerN, numberEqual, 4 | equal, less, lessEqual, greater, greaterEqual, unequal, 5 | isZero, isOne, isDouble, inexactQ, toNumberDouble) 6 | where 7 | 8 | import Data.Ratio 9 | import Data.Function(on) 10 | import Data.Maybe 11 | import Control.Monad 12 | -- import Data.Number.Hier 13 | -- Number Type 14 | data Number = Double Double 15 | | Rational Rational 16 | | Integer Integer 17 | deriving(Eq,Ord) 18 | 19 | data Unpacker = forall a. Num a => 20 | Unpacker (Number -> Maybe (a, a -> Number)) --(a -> a -> a) 21 | 22 | 23 | unpackInteger (Integer a) = Just (a, Integer) 24 | unpackInteger _ = Nothing 25 | 26 | castToInteger (Integer a) = a 27 | castToInteger (Rational a) = round a 28 | castToInteger (Double a) = round a 29 | 30 | unpackRational (Integer a) = Just (fromInteger a, Rational) 31 | unpackRational (Rational a) = Just (a, Rational) 32 | unpackRational _ = Nothing 33 | 34 | unpackDouble' (Integer a) = fromInteger a 35 | unpackDouble' (Rational a) = fromRational a 36 | unpackDouble' (Double a) = a 37 | 38 | unpackDouble a = Just (unpackDouble' a, Double) 39 | 40 | toNumberDouble = Double . unpackDouble' 41 | 42 | -- | unpacker list 43 | unpackers :: [Unpacker] 44 | unpackers = [Unpacker unpackInteger, Unpacker unpackRational, Unpacker unpackDouble] 45 | 46 | instance Show Number where 47 | show (Integer i) = show i 48 | show (Double d) = show d 49 | show (Rational r) = show (numerator r) ++ "/" ++ show (denominator r) 50 | 51 | instance Num Number where 52 | (+) = numberLift (+) 53 | (-) = numberLift (-) 54 | (*) = numberLift (*) 55 | negate = numberMap negate 56 | abs = numberMap abs 57 | signum = numberMap signum 58 | fromInteger = Integer 59 | 60 | instance Fractional Number where 61 | fromRational = Rational 62 | recip (Integer a) = Rational $ 1 % a 63 | recip (Rational a) = Rational $ recip a 64 | recip (Double a) = Double $ recip a 65 | 66 | instance Real Number where 67 | toRational (Integer a) = toRational a 68 | toRational (Rational a) = a 69 | toRational (Double a) = toRational a 70 | 71 | instance Floating Number where 72 | pi = Double pi 73 | exp = doubleMap exp 74 | log = doubleMap log 75 | sqrt = doubleMap sqrt 76 | (**) = doubleLift (**) 77 | logBase = doubleLift logBase 78 | sin = doubleMap sin 79 | cos = doubleMap cos 80 | tan = doubleMap tan 81 | asin = doubleMap asin 82 | acos = doubleMap acos 83 | atan = doubleMap atan 84 | sinh = doubleMap sinh 85 | cosh = doubleMap cosh 86 | tanh = doubleMap tanh 87 | asinh = doubleMap asinh 88 | acosh = doubleMap acosh 89 | atanh = doubleMap atanh 90 | 91 | instance Enum Number where 92 | toEnum n = Integer (fromIntegral n) 93 | fromEnum n = fromInteger (castToInteger n) 94 | 95 | instance Integral Number where 96 | quot (Integer a) (Integer b) = Integer $ quot a b 97 | rem (Integer a) (Integer b) = Integer $ rem a b 98 | quotRem a b = (quot a b, rem a b) 99 | toInteger (Integer a) = a 100 | 101 | instance RealFrac Number where 102 | properFraction (Integer n) = (fromInteger n, 0) 103 | properFraction (Rational a) = fmap Rational (properFraction a) 104 | properFraction (Double a) = fmap Double (properFraction a) 105 | 106 | numberLift' :: Unpacker -> 107 | (forall a. Num a => a -> a -> a) -> 108 | Number -> Number -> Maybe Number 109 | numberLift' (Unpacker unpack) f a b = do 110 | (a', pack) <- unpack a 111 | (b', _) <- unpack b 112 | return $ pack (f a' b') 113 | -- | lift a arithmatic function to Number 114 | numberLift :: 115 | (forall a. Num a => a -> a -> a) -> 116 | Number -> Number -> Number 117 | numberLift f a b = 118 | fromJust $ msum attempts 119 | where 120 | attempts = [numberLift' unpack f a b | unpack <- unpackers] 121 | 122 | numberMap :: (forall a. Num a => a -> a) -> Number -> Number 123 | numberMap f (Integer a) = Integer (f a) 124 | numberMap f (Rational a) = Rational (f a) 125 | numberMap f (Double a) = Double(f a) 126 | 127 | doubleMap :: (Double -> Double) -> Number -> Number 128 | doubleMap f n = Double (f (unpackDouble' n)) 129 | 130 | 131 | doubleLift f a b = 132 | let a' = unpackDouble' a 133 | b' = unpackDouble' b 134 | in 135 | Double $ f a' b' 136 | 137 | powerN :: Number -> Number -> Maybe Number 138 | -- double a 139 | powerN (Double a) (Double b) = Just $ Double $ a ** b 140 | powerN (Double a) (Integer b) =Just $ Double $ a ^^ b 141 | powerN (Double a) (Rational b) =Just $ Double $ a ** fromRational b 142 | -- double b 143 | powerN (Integer a) (Double b) = Just $ Double $ fromIntegral a ** b 144 | powerN (Rational a) (Double b) =Just $ Double $ fromRational a ** b 145 | -- integer a 146 | powerN (Integer a) (Integer b) 147 | | b >= 0 = Just $ Integer $ a ^ b 148 | | otherwise = Just $ Rational ((1 % a) ^ negate b) 149 | powerN (Integer _) (Rational _) = Nothing 150 | -- integer b 151 | powerN (Rational a) (Integer b) 152 | | b >= 0 = Just $ Rational $ a ^ b 153 | | otherwise = Just $ Rational $ (1 / a) ^ negate b 154 | -- rational a 155 | powerN _ _ = Nothing 156 | 157 | numberEqual :: Number -> Number -> Bool 158 | numberEqual (Integer a) (Integer b) = a == b 159 | numberEqual (Double a) (Double b) = a == b 160 | numberEqual (Rational a) (Rational b) = a == b 161 | numberEqual a b = ((==) `on` unpackDouble') a b 162 | 163 | 164 | numberComp :: Number -> Number -> Ordering 165 | numberComp = compare `on` unpackDouble' 166 | 167 | compareOnNumber :: (Double -> Double -> Bool) -> Number -> Number -> Bool 168 | compareOnNumber comp = 169 | comp `on` unpackDouble' 170 | 171 | equal = compareOnNumber (==) 172 | 173 | less = compareOnNumber (<) 174 | 175 | lessEqual = compareOnNumber (<=) 176 | greater = compareOnNumber (>) 177 | greaterEqual = compareOnNumber (>=) 178 | 179 | unequal = compareOnNumber (/=) 180 | 181 | 182 | 183 | isZero :: Number -> Bool 184 | isZero = (== 0) 185 | -- 186 | isOne :: Number -> Bool 187 | isOne = (== 1) 188 | 189 | isDouble :: Number -> Bool 190 | isDouble (Double _) = True 191 | isDouble _ = False 192 | 193 | inexactQ :: Number -> Bool 194 | inexactQ = isDouble 195 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Eval.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE ExistentialQuantification#-} 2 | module Eval.Eval 3 | ( 4 | eval, 5 | evalWithRecord, 6 | eval', 7 | initialState, 8 | Primi, 9 | StateResult 10 | ) where 11 | 12 | import Data.DataType 13 | import Data.Environment.Environment 14 | import Data.Environment.Update 15 | import Data.Number.Number 16 | import Eval.Primitive.Primitives 17 | import Eval.Primitive.PrimiFunc 18 | import Data.Environment.EnvironmentType hiding(eval) 19 | import Eval.EvalHead 20 | import Data.Attribute 21 | 22 | 23 | import Control.Monad 24 | import Data.Ratio 25 | import Data.Maybe(fromMaybe) 26 | import Data.List(sort) 27 | import Control.Monad.Except 28 | import qualified Data.Map.Strict as M 29 | import Control.Monad.Trans.State 30 | import Control.Lens hiding (List, Context) 31 | 32 | initialState = PrimiEnv eval nullContext [] 4096 1 33 | 34 | evalWithRecord :: LispVal -> Primi 35 | evalWithRecord val = do 36 | (Number limit) <- getVariable atomLimit 37 | dep .= fromIntegral limit 38 | updateInOut atomIn val 39 | evaled <- eval val 40 | updateInOut atomOut evaled 41 | return evaled 42 | 43 | updateInOut :: LispVal -> LispVal -> StateResult () 44 | updateInOut atom val = do 45 | n <- uses line integer 46 | setVariable (List [atom, n]) val 47 | 48 | checkLimit :: StateResult () 49 | checkLimit = do 50 | exceed <- uses dep (<=0) 51 | if exceed 52 | then 53 | stateThrow LimitExceed 54 | else 55 | dep -= 1 56 | 57 | eval :: LispVal -> Primi 58 | eval val = do 59 | checkLimit 60 | x1 <- eval' val 61 | if x1 == val then return x1 else eval x1 62 | 63 | eval' :: LispVal -> Primi 64 | eval' (List (v:vs)) = do 65 | headE <- eval v 66 | arguments <- attributeEvaluateArgs headE vs 67 | args .= headE : arguments 68 | attTransform <$> evalHead headE 69 | 70 | eval' (Atom "$Line") = uses line integer 71 | 72 | eval' val@(Atom _) = use con >>= replaceContext val 73 | 74 | eval' n@(Number (Rational r)) 75 | | denominator r == 1 = return (integer $ numerator r) 76 | | otherwise = return n 77 | 78 | eval' x = return x 79 | 80 | -- eval head -------------------------------------- 81 | evalPrimitiveHead :: LispVal -> Maybe Primi 82 | evalPrimitiveHead (Atom name) = 83 | M.lookup name primitives 84 | 85 | evalWithEnv :: Primi 86 | evalWithEnv = do 87 | lhs <- noChange 88 | if validSet lhs 89 | then use con >>= replaceContext lhs 90 | else noChange 91 | 92 | evalHead :: LispVal -> Primi 93 | evalHead h@(Atom _) = 94 | fromMaybe evalWithEnv (evalPrimitiveHead h) 95 | evalHead (List (Atom "Function":rest)) = 96 | evalLambda 97 | evalHead _ = noChange 98 | -- ------------------------------------------------ 99 | 100 | 101 | -- attribute relating functions 102 | -- | evaluate arguments under the attributes specification of Head 103 | attributeEvaluateArgs :: 104 | LispVal -> [LispVal] -> StateResult [LispVal] 105 | attributeEvaluateArgs h rests = do 106 | let att = getAttributes h attributes 107 | evaled <- attEvalHold att rests 108 | return $ allAttr att h evaled 109 | 110 | -- | handle HoldAll HoldFirst HoldRest 111 | attEvalHold:: 112 | [Attribute] -> [LispVal] -> StateResult [LispVal] 113 | attEvalHold atts vals 114 | | elem HoldAll atts = return vals 115 | | elem HoldFirst atts = do 116 | rest <- mapM evaluate (tail vals) 117 | return (head vals : rest) 118 | | elem HoldRest atts = do 119 | first <- evaluate (head vals) 120 | return (first : tail vals) 121 | | otherwise = mapM evaluate vals 122 | 123 | 124 | attTransform :: LispVal -> LispVal 125 | attTransform val = attributeTransform attributes val 126 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/EvalHead.hs: -------------------------------------------------------------------------------- 1 | module Eval.EvalHead(evalLambda) where 2 | 3 | import Eval.Primitive.Function.Lambda 4 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Patt/Pattern.hs: -------------------------------------------------------------------------------- 1 | module Eval.Patt.Pattern where 2 | 3 | import Data.DataType 4 | import Data.Environment.EnvironmentType 5 | 6 | import Data.Maybe 7 | import Data.Function(on) 8 | import Control.Monad 9 | import qualified Data.Text as T 10 | 11 | 12 | 13 | blankQ :: Pattern -> Bool 14 | blankQ (List (Atom "Blank" : _)) = True 15 | blankQ _ = False 16 | 17 | blankEq :: Pattern -> Pattern -> Bool 18 | blankEq a b 19 | | blankQ a && blankQ b = True 20 | | otherwise = False 21 | 22 | blankEqui = blankEq `on` unpackPatt 23 | 24 | unpackPatt :: Pattern -> Pattern 25 | unpackPatt (List [Atom "Pattern",_,patt]) = unpackPatt patt 26 | unpackPatt other = other 27 | 28 | patternEqui :: Pattern -> Pattern -> Bool 29 | patternEqui (List as) (List bs) = 30 | let el = length as == length bs 31 | pl = and $ zipWith patternEqui as bs in 32 | el && pl 33 | patternEqui a b = a == b || blankEqui a b 34 | 35 | 36 | isPattern :: LispVal -> Bool 37 | isPattern (Atom "Pattern") = True 38 | isPattern (Atom "Blank") = True 39 | isPattern (Atom "BlankSequence") = True 40 | isPattern (Atom "BlankNullSequence") = True 41 | isPattern (List xs) = any isPattern xs 42 | isPattern _ = False 43 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Patt/PatternPrimi.hs: -------------------------------------------------------------------------------- 1 | module Eval.Patt.PatternPrimi where 2 | 3 | import Data.DataType 4 | import Data.Environment.EnvironmentType 5 | import Eval.Patt.Regengine 6 | 7 | import qualified Data.Text as T 8 | import Control.Monad 9 | import Data.Maybe 10 | import qualified Data.Map.Strict as M 11 | 12 | 13 | 14 | getMatchP :: ParsedPatt -> LispVal -> MatchResult 15 | getMatchP p l = runMatching (patternMatching p l) 16 | 17 | getMatch = getMatchP . transformLispPattern 18 | 19 | -- | replace a lispval with a pattern matching specification 20 | replaceP :: LispVal -> ParsedRule -> ReplaceResult 21 | replaceP val (patt, target) = do 22 | matched <- getMatchP patt val 23 | return $ fmap (internalReplace target) matched 24 | 25 | replace val (p, t) = replaceP val (transformLispPattern p, t) 26 | 27 | -- | replace at the top level with a list of rule, return the first success, lazy state assures short circuit 28 | replaceRuleListP :: LispVal -> [ParsedRule] -> ReplaceResult 29 | replaceRuleListP val rules = 30 | fmap msum (mapM (replaceP val) rules) 31 | 32 | replaceRuleList val = replaceRuleListP val . map fromRule 33 | 34 | 35 | tryReplaceRuleListP :: LispVal -> [ParsedRule] -> Primi 36 | tryReplaceRuleListP val = fmap (fromMaybe val) . replaceRuleListP val 37 | 38 | tryReplaceRuleList val = tryReplaceRuleListP val . map fromRule 39 | 40 | -- | replace all with a list of rule, top-down 41 | replaceAllP :: [ParsedRule] -> LispVal -> Primi 42 | replaceAllP rules val = 43 | let ifFailed = 44 | case val of 45 | List lis -> fmap List (mapM (replaceAllP rules) lis) 46 | _ -> return val in 47 | do 48 | now <- replaceRuleListP val rules 49 | case now of 50 | Nothing -> ifFailed 51 | Just val -> return val 52 | 53 | replaceAll rules = replaceAllP (map fromRule rules) 54 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Patt/Regengine.hs: -------------------------------------------------------------------------------- 1 | module Eval.Patt.Regengine where 2 | 3 | import Data.DataType 4 | import Data.Environment.EnvironmentType 5 | import Eval.Primitive.PrimiFunc 6 | import Eval.Patt.Pattern 7 | import Data.Number.Number 8 | 9 | 10 | import Control.Monad 11 | import qualified Data.Map.Strict as M 12 | import Data.Maybe 13 | import qualified Data.Text as T 14 | 15 | -- MatchState facility 16 | 17 | type ParsedRule = (ParsedPatt, LispVal) 18 | 19 | fromRule :: Rule -> ParsedRule 20 | fromRule (p, l) = (transformLispPattern p, l) 21 | 22 | data MatchState a = 23 | MatchState {getMatchF :: MatchRes -> StateResult (Maybe (MatchRes, a))} 24 | 25 | instance Functor MatchState where 26 | fmap f (MatchState patt) = 27 | let foo res = do 28 | matchRes <- patt res 29 | return $ case matchRes of 30 | Nothing -> Nothing 31 | Just (res', ans) -> Just (res', f ans) 32 | in 33 | MatchState foo 34 | 35 | instance Applicative MatchState where 36 | pure a = MatchState (\res -> return (Just (res, a))) 37 | (MatchState f1) <*> m2 = 38 | let foo res = do 39 | matchRes <- f1 res 40 | case matchRes of 41 | Nothing -> return Nothing 42 | Just (res', ansF) -> getMatchF (fmap ansF m2) res' 43 | in 44 | MatchState foo 45 | 46 | instance Monad MatchState where 47 | return = pure 48 | (MatchState f1) >>= f2 = 49 | let foo res = do 50 | matchRes <- f1 res 51 | case matchRes of 52 | Nothing -> return Nothing 53 | Just (res', r1) -> getMatchF (f2 r1) res' 54 | in 55 | MatchState foo 56 | 57 | 58 | updateMatch :: (MatchRes -> MatchRes) -> MatchState () 59 | updateMatch f = 60 | let foo res = 61 | return (Just (f res, ())) in 62 | MatchState foo 63 | 64 | getMatchRes :: MatchState MatchRes 65 | getMatchRes = 66 | let foo res = 67 | return (Just (res, res)) in 68 | MatchState foo 69 | 70 | addNewMatch :: T.Text -> LispVal -> MatchState () 71 | addNewMatch name expr = do 72 | res <- getMatchRes 73 | let checker = fmap (expr ==) (M.lookup name res) 74 | case checker of 75 | Nothing -> updateMatch (M.insert name expr) 76 | Just True -> return () 77 | Just False -> matchFailed 78 | 79 | matchFailed :: MatchState a 80 | matchFailed = MatchState (const (return Nothing)) 81 | 82 | emptyMatch :: MatchState () 83 | emptyMatch = return () 84 | 85 | patternTest :: LispVal -> MatchState () 86 | patternTest cond = 87 | let foo res = do 88 | test <- evaluate cond 89 | return $ if (trueQ test) then Just (res, ()) else Nothing 90 | in 91 | MatchState foo 92 | 93 | -- try running a match program, if failed, revert environment and return False else return True 94 | tryMatching :: MatchState a -> MatchState Bool 95 | tryMatching (MatchState f) = 96 | let foo res = do 97 | run <- f res 98 | return $ Just $ case run of 99 | Nothing -> (res, False) 100 | Just (res', _) -> (res', True) 101 | in 102 | MatchState foo 103 | 104 | runMatching :: MatchState () -> MatchResult 105 | runMatching (MatchState f) = (fmap . fmap) fst (f initialMatch) 106 | 107 | 108 | -- ------------------------------------------------------------ 109 | -- | replaceall a value with a set of match results 110 | internalReplace :: LispVal -> MatchRes -> LispVal 111 | internalReplace val@(Atom name) ms = 112 | fromMaybe val (M.lookup name ms) 113 | internalReplace (List ls) ms = 114 | List $ map (`internalReplace` ms) ls 115 | internalReplace other _ = other 116 | 117 | -- | convert bool to match result 118 | fromBool :: Bool -> MatchState () 119 | fromBool True = emptyMatch 120 | fromBool _ = matchFailed 121 | 122 | -- regexp datatype ---------------------------- 123 | 124 | data AtomPatt = Literal LispVal 125 | | Blank 126 | | BlankSeq 127 | | BlankNullSeq 128 | deriving(Show) 129 | 130 | type PattTest = LispVal -> MatchState () 131 | 132 | data ParsedPatt = Single AtomPatt 133 | | WithTest PattTest ParsedPatt 134 | | Alt [ParsedPatt] 135 | | Bind T.Text ParsedPatt 136 | | Then [ParsedPatt] [PatternType] 137 | 138 | 139 | data PatternType = One 140 | | Seq 141 | | NullSeq 142 | 143 | parsePatternType :: ParsedPatt -> PatternType 144 | parsePatternType (Single BlankSeq) = Seq 145 | parsePatternType (Single BlankNullSeq) = NullSeq 146 | parsePatternType (Single _) = One 147 | parsePatternType (WithTest _ p) = parsePatternType p 148 | parsePatternType (Alt ps) = pattSum (map parsePatternType ps) 149 | where 150 | pattSum = foldr f One 151 | f One x = x 152 | f Seq One = Seq 153 | f Seq NullSeq = NullSeq 154 | f NullSeq _ = NullSeq 155 | parsePatternType (Bind _ p) = parsePatternType p 156 | parsePatternType (Then ps _) = One 157 | 158 | 159 | makePatternTest :: LispVal -> PattTest 160 | makePatternTest f b = patternTest (applyHead f b) 161 | 162 | makeCondition :: LispVal -> PattTest 163 | makeCondition f _ = do 164 | match <- getMatchRes 165 | patternTest (internalReplace f match) 166 | 167 | makeBlankTest :: T.Text -> PattTest 168 | makeBlankTest name (List (Atom matched :_)) = 169 | fromBool (name == matched) 170 | makeBlankTest "Integer" (Number (Integer _)) = emptyMatch 171 | makeBlankTest "Rational" (Number (Rational _)) = emptyMatch 172 | makeBlankTest "Real" (Number (Double _)) = emptyMatch 173 | makeBlankTest "Symbol" (Atom _) = emptyMatch 174 | makeBlankTest _ _ = matchFailed 175 | 176 | mapSequence :: PattTest -> PattTest 177 | mapSequence k (List ((Atom "Sequence") : ls)) = 178 | mapM_ k ls 179 | mapSequence _ _ = matchFailed 180 | 181 | 182 | -- parse reg expr from LispVal 183 | type ParseLispval = LispVal -> Maybe ParsedPatt 184 | 185 | parseBlank :: ParseLispval 186 | parseBlank (List [Atom "Blank"]) = 187 | Just (Single Blank) 188 | parseBlank (List [Atom "Blank", Atom y]) = 189 | Just (WithTest (makeBlankTest y) (Single Blank)) 190 | parseBlank _ = Nothing 191 | 192 | 193 | blanks = ["BlankSequence", "BlankNullSequence"] 194 | blankCons = zip blanks [BlankSeq, BlankNullSeq] 195 | 196 | parseBlankSeq :: ParseLispval 197 | parseBlankSeq (List [Atom x]) = 198 | fmap Single $ lookup x blankCons 199 | parseBlankSeq (List [Atom x, Atom y]) = 200 | fmap (WithTest (mapSequence (makeBlankTest y)) . Single) $ lookup x blankCons 201 | parseBlankSeq _ = Nothing 202 | 203 | parsePattern :: ParseLispval 204 | parsePattern (List [Atom "Pattern", Atom name, pattern]) = 205 | fmap (Bind name) $ parsePatt pattern 206 | parsePattern _ = Nothing 207 | 208 | patternTestType :: ParsedPatt -> PattTest -> PattTest 209 | patternTestType pp f = 210 | case parsePatternType pp of 211 | One -> f 212 | _ -> mapSequence f 213 | 214 | parsePatternTest :: ParseLispval 215 | parsePatternTest (List [Atom "PatternTest", p, f]) = 216 | do 217 | parsed <- parsePatt p 218 | return (WithTest (patternTestType parsed (makePatternTest f)) parsed) 219 | parsePatternTest _ = Nothing 220 | 221 | parseCondition :: ParseLispval 222 | parseCondition (List [Atom "Condition", p, f]) = 223 | fmap (WithTest (makeCondition f)) $ parsePatt p 224 | parseCondition _ = Nothing 225 | 226 | parseAlternative :: ParseLispval 227 | parseAlternative (List (Atom "Alternatives":as)) = do 228 | rest <- mapM parsePatt as 229 | return (Alt rest) 230 | parseAlternative _ = Nothing 231 | 232 | liftLiteral :: LispVal -> ParsedPatt 233 | liftLiteral = Single . Literal 234 | 235 | parseList :: ParseLispval 236 | parseList (List ls) = do 237 | rest <- mapM parsePatt ls 238 | return (Then rest (map parsePatternType rest)) 239 | parseList _ = Nothing 240 | 241 | parseLiteral :: ParseLispval 242 | parseLiteral x = Just (liftLiteral x) 243 | 244 | parsers = [parseBlank, parseBlankSeq, parsePattern, parsePatternTest, 245 | parseCondition, parseAlternative, parseList, parseLiteral] 246 | 247 | parsePatt :: ParseLispval 248 | parsePatt val = msum (map ($ val) parsers) 249 | 250 | transformLispPattern :: LispVal -> ParsedPatt 251 | transformLispPattern = fromJust . parsePatt 252 | 253 | -- ---------------------------------------------------- 254 | 255 | patternMatching :: ParsedPatt -> LispVal -> MatchState () 256 | patternMatching (Single (Literal p)) l = fromBool $ p == l 257 | patternMatching (Single _) l = emptyMatch 258 | patternMatching (WithTest test p) l = 259 | let 260 | allP = allPossibleMatch p l 261 | in 262 | tryMatchList (map (>> test l) allP) 263 | patternMatching (Alt alts) l = matchAlt alts l 264 | patternMatching (Bind name p) l = do 265 | patternMatching p l 266 | addNewMatch name l 267 | patternMatching (Then ps ts) (List ls) = 268 | matchThen ps ts ls 269 | patternMatching _ _ = matchFailed 270 | 271 | allPossibleMatch :: ParsedPatt -> LispVal -> [MatchState ()] 272 | allPossibleMatch (Then ps ts) (List ls) = matchThenAll ps ts ls 273 | allPossibleMatch patt lisp = [patternMatching patt lisp] 274 | 275 | tryMatchList :: [MatchState ()] -> MatchState () 276 | tryMatchList [] = matchFailed 277 | tryMatchList (m:ms) = do 278 | flag <- tryMatching m 279 | if flag then 280 | emptyMatch 281 | else tryMatchList ms 282 | 283 | matchAlt :: [ParsedPatt] -> LispVal -> MatchState () 284 | matchAlt ps l = tryMatchList (map (`patternMatching` l) ps) 285 | 286 | 287 | splitsFrom s st = [splitAt n st | n <- [s .. length st]] 288 | -- splits = splitsFrom 0 289 | -- frontSplit = splitsFrom 1 290 | 291 | matchThenAll :: [ParsedPatt] -> [PatternType] -> [LispVal] -> [MatchState ()] 292 | matchThenAll [] _ [] = [emptyMatch] 293 | matchThenAll [] _ _ = [] 294 | matchThenAll [p] [NullSeq] ls = [patternMatching p (wrapSequence ls)] 295 | matchThenAll [p] [Seq] ls 296 | | ls == [] = [] 297 | | otherwise = [patternMatching p (wrapSequence ls)] 298 | matchThenAll (p:ps) (t:ts) ls = 299 | let 300 | allocateMatch n = 301 | -- [patternMatching p (wrapSequence fs) >> rest 302 | [rest >> patternMatching p (wrapSequence fs) 303 | | (fs, bs) <- splitsFrom n ls, rest <- matchThenAll ps ts bs] 304 | in 305 | case t of 306 | One -> 307 | if (ls == []) then [] 308 | else 309 | map (patternMatching p (head ls) >>) (matchThenAll ps ts (tail ls)) 310 | Seq -> 311 | allocateMatch 1 312 | NullSeq -> allocateMatch 0 313 | 314 | 315 | 316 | matchThen :: [ParsedPatt] -> [PatternType] -> [LispVal] -> MatchState () 317 | matchThen p t l = tryMatchList (matchThenAll p t l) 318 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Arithmatic/Arithmatic.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Arithmatic.Arithmatic 2 | ( 3 | -- * Functions related with arithmatic. Plus, Times, Power etc... 4 | plusl,timesl,powerl,dividel,minusl,logl) where 5 | import Data.DataType 6 | import Data.Number.Number 7 | import Eval.Primitive.PrimiFunc 8 | import Data.Environment.EnvironmentType 9 | 10 | import Control.Monad 11 | import Control.Monad.Except 12 | import Data.List 13 | 14 | 15 | timesOrPlus :: (Number -> Number -> Number) -> 16 | Number -> 17 | UnpackArith -> 18 | Packer -> 19 | (Number -> [LispVal] -> Primi) -> 20 | Primi 21 | timesOrPlus mp zero unpacker pack merge = do 22 | (nums, syms) <- fmap (span checkNum) getArgumentList 23 | let unpacked = map unpackNum nums 24 | ans = foldl mp zero unpacked 25 | fmap sortList $ merge ans (totalSimplify unpacker pack syms) 26 | 27 | mergePlus,mergeTimes :: Number -> [LispVal] -> Primi 28 | mergePlus num [] = return (Number num) 29 | mergePlus 0 xs = tagHead xs 30 | mergePlus num xs = tagHead (Number num : xs) 31 | 32 | mergeTimes num [] = return (Number num) 33 | mergeTimes 0 xs = return (Number 0) 34 | mergeTimes 1 xs = tagHead xs 35 | mergeTimes num xs = tagHead (Number num : xs) 36 | 37 | -- groupPlus,groupTimes :: [LispVal] -> LispVal 38 | -- groupPlus [single] = single 39 | -- groupPlus xs = List [Atom "Times", Number (genericLength xs), head xs] 40 | -- 41 | -- groupTimes [single] = single 42 | -- groupTimes xs = List [Atom "Power", head xs, Number (genericLength xs)] 43 | -- -------------------------------------------------- 44 | -- | expected exactly two arguments 45 | minus, divide :: [LispVal] -> LispVal 46 | minus [Number a, Number b] = Number $ a - b 47 | minus [a, b] = minus' a b 48 | where 49 | minus' a b = List [Atom "Plus", a, List [Atom "Times", Number (-1), b]] 50 | 51 | divide [Number a, Number b] = Number $ a / b 52 | divide [a, b] = divide' a b 53 | where 54 | divide' a b = List [Atom "Times", a, List [Atom "Power", b, Number (-1)]] 55 | 56 | minusOrDivide :: ([LispVal] -> LispVal) -> Primi 57 | minusOrDivide f = do 58 | withnop 2 59 | fmap f getArgumentList 60 | 61 | minusl, dividel, timesl, plusl :: Primi 62 | minusl = minusOrDivide minus 63 | dividel = minusOrDivide divide 64 | timesl = timesOrPlus (*) 1 unpackPower packPower mergeTimes 65 | plusl = timesOrPlus (+) 0 unpackTimes packTimes mergePlus 66 | 67 | powerl :: Primi 68 | powerl = do 69 | withnop 2 70 | [a, b] <- getArgumentList 71 | case (a, b) of 72 | (Number a1, Number b1) -> maybe noChange (return.Number) (powerN a1 b1) 73 | (_, Number 0) -> return (Number 1) 74 | (a, Number 1) -> return a 75 | (List [Atom "Power", n1, n2], b) -> return (List [Atom "Power", n1, List[Atom "Times", b, n2]]) 76 | _ -> noChange 77 | 78 | logl :: Primi 79 | logl = do 80 | withnop 1 81 | [a] <- getArgumentList 82 | case a of 83 | Number 1 -> return (Number 0) 84 | _ -> noChange 85 | 86 | type UnpackArith = LispVal -> (Number, [LispVal]) 87 | type Packer = Number -> [LispVal] -> LispVal 88 | unpackTimes :: UnpackArith 89 | unpackTimes (List (Atom "Times" : Number a : res)) = (a, res) 90 | unpackTimes (List (Atom "Times" : res)) = (1, res) 91 | unpackTimes val = (1, [val]) 92 | 93 | packTimes :: Packer 94 | packTimes 0 _ = Number 0 95 | packTimes 1 [res] = res 96 | packTimes 1 res = List (Atom "Times":res) 97 | packTimes n res = List (Atom "Times" : Number n : res) 98 | 99 | unpackPower :: UnpackArith 100 | unpackPower (List [Atom "Power", res, Number a]) = (a, [res]) 101 | unpackPower val = (1, [val]) 102 | 103 | packPower :: Packer 104 | packPower 0 _ = Number 1 105 | packPower 1 res = head res 106 | packPower n res = List [Atom "Power", head res, Number n] 107 | 108 | -- simplify :: UnpackArith -> Packer -> Number -> [LispVal] -> [LispVal] -> [LispVal] 109 | -- simplify unpacker pack n res val@(x:xs) = 110 | -- let (n2, res2) = unpacker x 111 | -- simplified = pack n res : totalSimplify unpacker pack val 112 | -- in 113 | -- if res == res2 then 114 | -- simplify unpacker pack (n + n2) res xs 115 | -- else 116 | -- simplified 117 | -- simplify _ pack n res [] = [pack n res] 118 | 119 | simplify :: [(Number, [LispVal])] -> [(Number, [LispVal])] 120 | simplify [] = [] 121 | simplify [x] = [x] 122 | simplify ((n1, res1):(n2, res2):xs) 123 | | res1 == res2 = (n1+n2, res1) : simplify xs 124 | | otherwise = (n1, res1) : simplify ((n2,res2):xs) 125 | 126 | totalSimplify :: UnpackArith -> Packer -> [LispVal] -> [LispVal] 127 | totalSimplify unpacker pack xs = 128 | let unpacked = map unpacker xs 129 | sorted = sortOn snd unpacked in 130 | map (uncurry pack) (simplify sorted) 131 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Compare/Compare.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Compare.Compare 2 | (equall,lessl,lessEquall,greaterl,greaterEquall,inequalityl) where 3 | import Data.DataType 4 | import Data.Number.Number 5 | import Eval.Primitive.PrimiFunc 6 | import Data.Environment.EnvironmentType hiding(eval) 7 | 8 | import Control.Monad 9 | import Control.Monad.Except 10 | import Data.Maybe 11 | import qualified Data.Text as T 12 | 13 | 14 | equall = comparel equal 15 | lessl = comparel less 16 | lessEquall = comparel lessEqual 17 | greaterl = comparel greater 18 | greaterEquall = comparel greaterEqual 19 | 20 | comparel :: (Number -> Number -> Bool) -> Primi 21 | comparel comp = usesArgumentMaybe (compareMaybe comp) 22 | 23 | compareMaybe :: (Number -> Number -> Bool) -> [LispVal] -> Maybe LispVal 24 | compareMaybe comp ls = do 25 | unpacked <- unpack ls 26 | return (toBool $ compareFunction comp unpacked) 27 | 28 | compareFunction :: (Number -> Number -> Bool) -> [Number] -> Bool 29 | compareFunction _ [] = True 30 | compareFunction _ [_] = True 31 | compareFunction comp (x1:x2:xs) = 32 | comp x1 x2 && compareFunction comp (x2:xs) 33 | 34 | unpack :: [LispVal] -> Maybe [Number] 35 | unpack = mapM unpacknum 36 | 37 | unpacknum (Number a) = Just a 38 | unpacknum _ = Nothing 39 | 40 | -- inequalityl 41 | compareNumber :: (Number -> Number -> Bool) -> LispVal -> LispVal -> Maybe Bool 42 | compareNumber f x y = do 43 | x' <- unpacknum x 44 | y' <- unpacknum y 45 | return $ f x' y' 46 | 47 | compareTable :: [(T.Text, LispVal -> LispVal -> Maybe Bool)] 48 | compareTable = [ 49 | ("Equal",compareNumber equal), 50 | ("Greater", compareNumber greater), 51 | ("GreaterEqual", compareNumber greaterEqual), 52 | ("Less", compareNumber less), 53 | ("LessEqual", compareNumber lessEqual), 54 | ("Unequal", compareNumber unequal) 55 | ] 56 | 57 | 58 | eval :: LispVal -> LispVal -> LispVal -> Maybe Bool 59 | eval (Atom name) x y = do 60 | f <- lookup name compareTable 61 | f x y 62 | 63 | inequalityl :: Primi 64 | inequalityl = usesArgumentError (lift . inequal) 65 | 66 | 67 | inequal :: [LispVal] -> IOThrowsError LispVal 68 | inequal xs = 69 | let l = length xs in 70 | if l >= 3 && odd l then do 71 | let res = inequalityl' xs 72 | return $ case res of 73 | Atom _ -> res 74 | List xs -> List (Atom "Inequality" : xs) 75 | else 76 | throwError (Default "Inequality's number of arguments expected to be an odd number >= 3") 77 | 78 | 79 | -- eliminate left 80 | inequalityRight :: [LispVal] -> LispVal 81 | inequalityRight val@[a,comp,b] = 82 | maybe (List val) toBool (eval comp a b) 83 | inequalityRight (a:comp:b:rest) = 84 | let res = eval comp a b 85 | restRes = inequalityRight (b:rest) 86 | check True = case restRes of 87 | val@(Atom _) -> val 88 | List xs -> List (a:comp:xs) 89 | check False = false 90 | checkRest (Atom "True") = List [a,comp,b] 91 | checkRest (Atom _) = false 92 | checkRest (List xs) = List (a:comp:xs) 93 | ifNothing = checkRest restRes 94 | in 95 | maybe ifNothing check res 96 | 97 | -- eliminate right 98 | inequalityl' :: [LispVal] -> LispVal 99 | inequalityl' val@[a,comp,b] = 100 | maybe (List val) toBool (eval comp a b) 101 | inequalityl' (a:comp:b:rest) = 102 | let res = eval comp a b 103 | left = inequalityRight (b:rest) 104 | goOn = inequalityl' (b:rest) 105 | check True = goOn 106 | check False = false 107 | checkRest (Atom "True") = List [a,comp,b] 108 | checkRest (Atom _) = false 109 | checkRest (List xs) = List (a:comp:xs) 110 | ifNothing = checkRest left 111 | in 112 | maybe ifNothing check res 113 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Control/Branch.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Control.Branch(ifl) where 2 | import Data.DataType 3 | import Eval.Primitive.PrimiFunc 4 | import Data.Environment.EnvironmentType 5 | 6 | import Data.Maybe 7 | 8 | ifl :: Primi 9 | ifl = do 10 | between 3 4 11 | usesArgumentMaybe ifl' 12 | 13 | if3Args :: [LispVal] -> Maybe LispVal 14 | if3Args [predict, r1,r2] 15 | | isBool predict = Just $ if trueQ predict then r1 else r2 16 | | otherwise = Nothing 17 | 18 | ifl' :: [LispVal] -> Maybe LispVal 19 | ifl' args 20 | | length args == 3 = if3Args args 21 | | otherwise = Just $ fromMaybe (last args) (if3Args (init args)) 22 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Function/Lambda.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE FlexibleContexts #-} 2 | 3 | module Eval.Primitive.Function.Lambda(evalLambda,functionl) where 4 | 5 | import Data.DataType 6 | import Eval.Patt.PatternPrimi 7 | import Eval.Primitive.PrimiFunc 8 | import Data.Environment.EnvironmentType 9 | import Eval.Patt.Regengine 10 | 11 | import Control.Monad.Trans.Except 12 | import Control.Monad.Except 13 | import Control.Monad 14 | import qualified Data.Map.Strict as M 15 | 16 | 17 | 18 | slotErr = Default "Slot should contain a non-negative integer" 19 | slotSeqErr = Default "SlotSequence should contain a positive integer" 20 | fpct = Default "Function:: Too many parameters to be filled" 21 | flpr = Default "Function :: Parameter specification error" 22 | 23 | unpackSlotNum,unpackSlotSeqNum :: LispVal -> IOThrowsError Int 24 | unpackSlotNum = unpackIntWithThre 0 slotErr 25 | unpackSlotSeqNum = unpackIntWithThre 1 slotSeqErr 26 | 27 | unpackSlot vs [n] = do 28 | n' <- unpackSlotNum n 29 | if length vs < n'+1 then 30 | throwError (SlotError (head vs)) 31 | else return $ vs !! n' 32 | unpackSlot _ other = throwError (NumArgs "Slot" 1 (length other)) 33 | 34 | unpackSlotSeq vs [n] = do 35 | n' <- unpackSlotSeqNum n 36 | if length vs < n' then 37 | throwError (SlotError (head vs)) 38 | else return $ wrapSequence (drop n' vs) 39 | unpackSlotSeq _ other = throwError (NumArgs "SlotSequence" 1 (length other)) 40 | 41 | 42 | replaceSlot :: [LispVal] -> LispVal -> IOThrowsError LispVal 43 | replaceSlot vs (List val@(Atom "Slot":inds)) = 44 | unpackSlot vs inds 45 | replaceSlot vs (List val@(Atom "SlotSequence":inds)) = 46 | unpackSlotSeq vs inds 47 | replaceSlot _ val@(List (Atom "Function":_)) = return val 48 | replaceSlot vs (List lis) = 49 | fmap List $ mapM (replaceSlot vs) lis 50 | replaceSlot _ val = return val 51 | 52 | unpackPara :: LispVal -> [LispVal] -> IOThrowsError [Matched] 53 | unpackPara (Atom _) [] = throwError fpct 54 | unpackPara (Atom name) vals = return [(name,head vals)] 55 | unpackPara (List (Atom "List":paras)) vals = 56 | if length paras > length vals then 57 | throwError fpct 58 | else 59 | return $ zip (map unpackAtom paras) vals 60 | 61 | replaceVar paras args body = do 62 | matched <- unpackPara paras args 63 | return $ internalReplace body (M.fromList matched) 64 | 65 | evalLambda :: Primi 66 | evalLambda = do 67 | lis@(List fun:args) <- getArgs 68 | case fun of 69 | [_,slots] -> lift $ replaceSlot lis slots 70 | _:para:body:_ -> lift $ replaceVar para args body 71 | 72 | 73 | functionl :: Primi 74 | functionl = do 75 | between 1 3 76 | getArgumentList >>= checkFunction 77 | 78 | checkFunction :: [LispVal] -> Primi 79 | checkFunction [_] = noChange 80 | checkFunction (Atom _ :_) = noChange 81 | checkFunction (List (Atom "List":ps) :_) = do 82 | lift $ mapM_ checkAtom ps 83 | noChange 84 | checkFunction _ = stateThrow flpr 85 | 86 | checkAtom (Atom _) = return () 87 | checkAtom _ = throwError flpr 88 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/IO/Print.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.IO.Print 2 | (printl) where 3 | 4 | import Eval.Primitive.PrimiFunc 5 | import Data.Environment.EnvironmentType 6 | import Data.DataType 7 | import Eval.Patt.Pattern 8 | import Show.Pretty 9 | 10 | import Control.Monad.Trans 11 | import qualified Data.Text.IO as T 12 | 13 | printl :: Primi 14 | printl = do 15 | vals <- getArgumentList 16 | let output = mconcat $ map showLispVal vals in 17 | (lift.lift) $ T.putStrLn output >> return atomNull 18 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/InOut/InOut.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.InOut.InOut 2 | (inl,outl) where 3 | 4 | import Eval.Primitive.PrimiFunc 5 | import Data.DataType 6 | import Data.Environment.Update 7 | import Data.Environment.EnvironmentType 8 | import Data.Environment.Environment 9 | 10 | 11 | import Data.IORef 12 | import Control.Monad 13 | import Control.Monad.Trans.Except 14 | import Control.Monad.Except 15 | import qualified Data.Text as T 16 | 17 | 18 | inl, outl :: Primi 19 | inl = indexl 20 | outl = indexl 21 | 22 | unpackError name = Default ("Machine-sized integer is expected in " `T.append` name) 23 | 24 | -- unpack the index arguement in In or Out 25 | unpack :: T.Text -> LispVal -> IOThrowsError Integer 26 | unpack name = 27 | unpackInt (unpackError name) 28 | 29 | plusLine :: LispVal -> LispVal 30 | plusLine val = List [Atom "Plus", atomLine, val] 31 | 32 | index :: LispVal -> Context -> [LispVal] -> Primi 33 | index fun@(Atom name) context [n] = do 34 | n' <- lift (unpack name n) 35 | if n' >= 0 then 36 | replaceContext (List [fun, n]) context 37 | else 38 | return $ List [fun, plusLine n] 39 | 40 | indexl :: Primi 41 | indexl = do 42 | withnop 1 43 | context <- getCon 44 | h:args <- getArgs 45 | index h context args 46 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/List/Cons.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.List.Cons 2 | (-- * List Construction function 3 | rangel) where 4 | 5 | import Data.DataType 6 | import Data.Number.Number 7 | import Eval.Primitive.PrimiFunc 8 | import Data.Environment.EnvironmentType 9 | 10 | import Control.Monad 11 | import Control.Monad.Except 12 | 13 | rangel :: Primi 14 | rangel = do 15 | between 1 3 16 | ls <- getArgumentList 17 | lift (rangel' ls) 18 | 19 | rangel' :: [LispVal] -> IOThrowsError LispVal 20 | rangel' ls = do 21 | ns <- toRangeArgs ls 22 | return $ fromNumberList (rangeLP ns) 23 | 24 | rangeLP :: [Number] -> [Number] 25 | rangeLP [n] = range 1 n 1 26 | rangeLP [f,t] = range f t 1 27 | rangeLP [f,t,d] = range f t d 28 | 29 | fromNumberList :: [Number] -> LispVal 30 | fromNumberList = list . map Number 31 | 32 | range :: Number -> Number -> Number -> [Number] 33 | range i j d = 34 | let n = truncate $ (j - i) / d in 35 | rangeFrom n i d 36 | 37 | rangeFrom :: Int -> Number -> Number -> [Number] 38 | rangeFrom n i d = take (n+1) (iterate (+ d) i) 39 | 40 | toRangeArgs :: [LispVal] -> IOThrowsError [Number] 41 | toRangeArgs ls = do 42 | ns <- mapM unpackNum' ls 43 | return $ toListDouble ns 44 | 45 | toListDouble :: [Number] -> [Number] 46 | toListDouble ls 47 | | any isDouble ls = map toNumberDouble ls 48 | | otherwise = ls 49 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/List/Elem.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.List.Elem( 2 | -- * Elementary list manipulation function 3 | carl,cdrl,lengthl,consl) where 4 | import Data.DataType 5 | import Data.Number.Number 6 | import Eval.Primitive.PrimiFunc 7 | import Data.Environment.EnvironmentType 8 | 9 | import Control.Monad.Except 10 | import Data.List 11 | 12 | lengthl, carl, cdrl, consl :: Primi 13 | lengthl = do 14 | withnop 1 15 | [obj] <- getArgumentList 16 | return $ case obj of 17 | List x -> Number (genericLength x - 1) 18 | _ -> Number 0 19 | 20 | carl = do 21 | withnop 1 22 | [obj] <- getArgumentList 23 | car obj 24 | 25 | cdrl = do 26 | withnop 1 27 | [obj] <- getArgumentList 28 | cdr obj 29 | 30 | consl = do 31 | withnop 2 32 | [a1, a2] <- getArgumentList 33 | cons a1 a2 34 | 35 | car, cdr :: LispVal -> Primi 36 | car (List []) = stateThrow (Default "car::empty list") 37 | car (List (x:_)) = return x 38 | car _ = noChange 39 | 40 | cdr (List []) = stateThrow (Default "cdr:: empty list") 41 | cdr (List (_:xs)) = return (List xs) 42 | cdr _ = noChange 43 | 44 | cons :: LispVal -> LispVal -> Primi 45 | cons val (List xs) = return $ List (val : xs) 46 | cons _ _ = stateThrow (Default "cons :: list expected") 47 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/List/Level.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.List.Level 2 | (-- * Module for level specification related functions 3 | levelFromTo, unpackLevelSpeci,unpackNormalLevelSpeci) 4 | where 5 | import Data.DataType 6 | import Data.Number.Number 7 | 8 | import Control.Monad.Identity 9 | import Control.Monad.Except 10 | 11 | type LevelSpeci = (LispVal -> LispVal) -> LispVal -> LispVal 12 | 13 | -- | Take a function and apply it to a lispval in the level range 14 | -- specified by the pair of ints. 15 | -- monad context to make general enough to implement Level like function. 16 | -- Negative specification is not currently implemented 17 | levelFromTo :: (Monad m) => 18 | (LispVal -> m LispVal) -> 19 | Int -> Int -> LispVal -> m LispVal 20 | levelFromTo f 0 0 x = f x 21 | levelFromTo f 0 j (List (l:ls)) = do 22 | let newf = levelFromTo f 0 (j - 1) 23 | mapped <- mapM newf ls 24 | f $ List (l : mapped) 25 | levelFromTo f 0 j other = f other 26 | levelFromTo f i j (List (l : ls)) = do 27 | let newf = levelFromTo f (i - 1) (j - 1) 28 | mapped <- mapM newf ls 29 | return $ List (l : mapped) 30 | levelFromTo _ _ _ other = return other 31 | 32 | levelAt f n = levelFromTo f n n 33 | 34 | levelUpTo f = levelFromTo f 1 35 | 36 | 37 | unpack :: LispVal -> LispVal -> IOThrowsError Int 38 | unpack val = unpackInt (Level val) 39 | 40 | -- | This function is used to unpack a level specification and 41 | -- returns a function that will apply a supplied function to 42 | -- a LispVal at desired level(s) 43 | unpackLevelSpeci :: (Monad m) => 44 | Int -- ^ Default level (will be used when the second argument is empty). 45 | -> [LispVal] -- ^ Level specification to be unpacked, could be empty, or taken as n, {n}, {i, j}. 46 | -> IOThrowsError ((LispVal -> m LispVal) -> LispVal -> m LispVal) 47 | unpackLevelSpeci def [] = return $ \f -> levelAt f def 48 | unpackLevelSpeci _ [val@(List [Atom "List",n])] = do 49 | n' <- unpack val n 50 | return $ \f -> levelAt f n' 51 | unpackLevelSpeci _ [val@(List [Atom "List", i, j])] = do 52 | let unpack' = unpack val 53 | i' <- unpack' i 54 | j' <- unpack' j 55 | return $ \f -> levelFromTo f i' j' 56 | unpackLevelSpeci _ [n] = do 57 | n' <- unpack n n 58 | return $ \f -> levelUpTo f n' 59 | unpackLevelSpeci _ val = throwError $ Level (List val) 60 | 61 | -- | This function will specified the Monad context in the 62 | -- unpackLevelSpeci function to be Identity in order to free from 63 | -- the Monad context. Used when defining Map, Apply ... 64 | unpackNormalLevelSpeci :: Int -> [LispVal] -> IOThrowsError LevelSpeci 65 | unpackNormalLevelSpeci n val = do 66 | levelSpeci <- unpackLevelSpeci n val 67 | return $ \f x -> runIdentity $ levelSpeci (Identity . f) x 68 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/List/List.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.List.List 2 | (partl,lengthl,carl,cdrl,consl,rangel,mapl,applyl) where 3 | 4 | import Eval.Primitive.List.Part 5 | import Eval.Primitive.List.Elem 6 | import Eval.Primitive.List.Cons 7 | import Eval.Primitive.List.Map 8 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/List/Map.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.List.Map(mapl,applyl) where 2 | import Eval.Primitive.List.Level 3 | import Data.DataType 4 | import Data.Number.Number 5 | import Eval.Primitive.PrimiFunc 6 | import Data.Environment.EnvironmentType 7 | 8 | 9 | import Control.Monad 10 | import Control.Monad.Except 11 | 12 | mapl :: Primi 13 | mapl = do 14 | between 2 3 15 | args <- getArgumentList 16 | lift (unpackArgs applyHead 1 args) 17 | 18 | applyl :: Primi 19 | applyl = do 20 | between 2 3 21 | args <- getArgumentList 22 | lift (unpackArgs changeHead 0 args) 23 | 24 | 25 | mapl' = unpackArgs applyHead 1 26 | applyl' = unpackArgs changeHead 0 27 | 28 | 29 | unpackArgs :: (LispVal -> LispVal -> LispVal) -> Int -> 30 | [LispVal] -> IOThrowsError LispVal 31 | unpackArgs fun def (f:app:speci) = do 32 | speciMap <- unpackNormalLevelSpeci def speci 33 | return (speciMap (fun f) app) 34 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/List/Part.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.List.Part(partl) where 2 | import Data.DataType 3 | import Data.Number.Number 4 | import Eval.Primitive.PrimiFunc 5 | import Data.Environment.EnvironmentType 6 | 7 | import Control.Monad 8 | import Control.Monad.Except 9 | 10 | partl :: Primi 11 | partl = do 12 | l <- getArgumentList 13 | expr <- getExpression 14 | case partWithPartError l of 15 | Left err -> stateThrow $ fromPartError err expr 16 | Right val -> return val 17 | 18 | 19 | data PartSpeci = S Int | L [Int] 20 | data PartRes = Sres LispVal | Lres [LispVal] 21 | data PartError = Pkspec | Partw | Partd 22 | type ThrowPart = Either PartError 23 | 24 | partWithPartError :: [LispVal] -> ThrowPart LispVal 25 | partWithPartError (l:ls) = do 26 | speci <- toPartSpeci ls 27 | partWithSpeci l speci 28 | 29 | toPartSpeci :: [LispVal] -> ThrowPart [PartSpeci] 30 | toPartSpeci = mapM toPartSpeci' 31 | where 32 | toPartSpeci' (List (Atom "List":res)) = liftM L $ mapM unpack res 33 | toPartSpeci' n = liftM S $ unpack n 34 | unpack :: LispVal -> ThrowPart Int 35 | unpack (Number (Integer n)) = return (fromIntegral n) 36 | unpack _ = throwError Pkspec 37 | 38 | partWithSpeci :: LispVal -> [PartSpeci] -> ThrowPart LispVal 39 | partWithSpeci l [] = return l 40 | partWithSpeci l (s:ss) = do 41 | parted <- partOnce l s 42 | case parted of 43 | Sres res -> partWithSpeci res ss 44 | Lres reses -> liftM list $ mapM (`partWithSpeci` ss) reses 45 | 46 | partOnce :: LispVal -> PartSpeci -> ThrowPart PartRes 47 | partOnce lv (S n) = liftM Sres $ getPart lv n 48 | partOnce lv (L ns) = liftM Lres $ mapM (getPart lv) ns 49 | 50 | getPart :: LispVal -> Int -> ThrowPart LispVal 51 | getPart (List lis) n = 52 | if length lis < n+1 then throwError Partw 53 | else return $ lis !! n 54 | getPart _ _ = throwError Partd 55 | 56 | fromPartError :: PartError -> LispVal -> LispError 57 | fromPartError Partd = PartE "part specification is longer than depth of object" 58 | fromPartError Partw = PartE "part specification does not exist" 59 | fromPartError Pkspec = PartE "invalid part specification" 60 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Logic/Logic.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Logic.Logic(andl, orl, notl) where 2 | 3 | import Data.DataType 4 | 5 | import Data.Number.Number 6 | import Eval.Primitive.PrimiFunc 7 | import Data.Environment.EnvironmentType 8 | import Control.Monad 9 | import Control.Monad.Trans.Class 10 | 11 | data Logic = Result LispVal | NonReulst [LispVal] 12 | 13 | unpackLogic :: LispVal -> Logic -> LispVal 14 | unpackLogic _ (Result val) = val 15 | unpackLogic h (NonReulst vals) = List (h: vals) 16 | 17 | logic :: LispVal 18 | -> [LispVal] -> StateResult Logic 19 | logic trivi [] = return (Result trivi) 20 | logic trivi (x:xs) = 21 | let rest = logic trivi xs 22 | check = (trivi ==) in 23 | do 24 | x' <- evaluate x 25 | if isBool x' then 26 | if check x' then 27 | rest 28 | else 29 | return (Result x') 30 | else do 31 | restRes <- rest 32 | return $ case restRes of 33 | NonReulst res -> NonReulst (x':res) 34 | Result res -> if check res then 35 | NonReulst [x'] else restRes 36 | 37 | logicLift :: LispVal -> Primi 38 | logicLift triviality = do 39 | arguments <- getArgumentList 40 | h <- getHead 41 | fmap (unpackLogic h) (logic triviality arguments) 42 | 43 | andl,orl,notl :: Primi 44 | -- | short circut evaluation implemented 45 | andl = logicLift true 46 | 47 | orl = logicLift false 48 | 49 | notl = do 50 | withnop 1 51 | usesArgumentMaybe notl' 52 | 53 | notl' :: [LispVal] -> Maybe LispVal 54 | notl' [Atom "True"] = Just false 55 | notl' [Atom "False"] = Just true 56 | notl' _ = Nothing 57 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Nest/Nest.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE FlexibleContexts #-} 2 | module Eval.Primitive.Nest.Nest(nestl, nestListl)where 3 | 4 | import Data.DataType 5 | import Data.Number.Number 6 | import Eval.Primitive.PrimiFunc 7 | import Data.Environment.EnvironmentType 8 | import Eval.Primitive.Replace.Replace 9 | 10 | import Control.Monad 11 | import Control.Monad.Except 12 | 13 | nestl ,nestListl:: Primi 14 | nestl = nestUnpack nest 15 | nestListl = nestUnpack nestList 16 | 17 | type Nest = LispVal -> LispVal -> Int -> Primi 18 | 19 | nest,nestList :: Nest 20 | nest _ arg 0 = return arg 21 | nest f arg n = do 22 | evaled <- evaluate (applyHead f arg) 23 | nest f evaled (n-1) 24 | 25 | nestList' _ arg 0 = return [arg] 26 | nestList' f arg n = do 27 | evaled <- evaluate (applyHead f arg) 28 | rest <- nestList' f evaled (n-1) 29 | return $ arg : rest 30 | nestList f arg n = fmap list (nestList' f arg n) 31 | 32 | 33 | nestErr = Default "Nest :: non-negative machine-sized number expected" 34 | 35 | nestUnpack :: Nest -> Primi 36 | nestUnpack nest = do 37 | withnop 3 38 | [f,arg,n] <- getArgumentList 39 | n' <- lift $ unpackIntWithThre 0 nestErr n 40 | nest f arg n' 41 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/PrimiFunc.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE FlexibleContexts#-} 2 | module Eval.Primitive.PrimiFunc where 3 | 4 | import Data.DataType 5 | import Data.Number.Number 6 | import Data.Environment.EnvironmentType 7 | 8 | import qualified Data.Map.Strict as M 9 | import Control.Monad 10 | import Control.Monad.Except 11 | import Control.Monad.Trans.State 12 | import Control.Lens hiding(List, Context) 13 | import Data.Maybe 14 | import qualified Data.Text as T 15 | 16 | stateThrow :: LispError -> StateResult a 17 | stateThrow = lift . throwError 18 | -- | The most genenral function to constraint the arguments number of 19 | -- primitive function 20 | checkArgsNumber :: (Int -> Bool) -> (LispVal -> Int -> IOThrowsError ()) -> 21 | StateResult () 22 | checkArgsNumber check throw = do 23 | num <- uses args ((\x -> x - 1) . length) 24 | unless (check num) $ do 25 | name <- uses args head 26 | lift (throw name num) 27 | 28 | -- | expects more than n arguments. 29 | manynop n = checkArgsNumber (>= n) throw 30 | where throw val x = throwError (NumArgsMore (unpackAtom val) n x) 31 | 32 | -- | expect more than one arugments 33 | many1op = manynop 1 34 | 35 | -- | argument list length is between l and r. 36 | between l r = checkArgsNumber (\x -> x >= l && x <= r) throw 37 | where throw val x = throwError (NumArgsBetween (unpackAtom val) l r x) 38 | 39 | -- | Ensure that the argument list has excatly n elements. 40 | withnop n = checkArgsNumber (== n) throw 41 | where throw val x = throwError (NumArgs (unpackAtom val) n x) 42 | 43 | -- | evaluate a LispVal with function in PrimiEnv context 44 | evaluate :: LispVal -> Primi 45 | evaluate val = do 46 | evalFun <- getEval 47 | evalFun val 48 | 49 | -- | get evaluate function 50 | getEval :: StateResult Eval 51 | getEval = use eval 52 | 53 | -- | get context 54 | getCon :: StateResult Context 55 | getCon = use con 56 | 57 | getLineNumber :: StateResult Int 58 | getLineNumber = use line 59 | 60 | -- | update context 61 | updateCon :: (Context -> Context) -> StateResult () 62 | updateCon f = con %= f 63 | 64 | 65 | -- | return args 66 | getArgs :: StateResult [LispVal] 67 | getArgs = use args 68 | 69 | -- | return the arguments that is currently being evaluated 70 | getArgumentList :: StateResult [LispVal] 71 | getArgumentList = uses args tail 72 | 73 | -- | apply function to argument list 74 | usesArgumentList :: ([LispVal] -> a) -> StateResult a 75 | usesArgumentList f = uses args (f . tail) 76 | 77 | -- | return original expression if evaluate to nothing 78 | usesArgumentMaybe :: ([LispVal] -> Maybe LispVal) -> StateResult LispVal 79 | usesArgumentMaybe f = do 80 | expr <- getExpression 81 | usesArgumentList (fromMaybe expr . f) 82 | 83 | -- | lift a IOThrowsError to StateResult 84 | usesArgumentError :: EvalArguments -> Primi 85 | usesArgumentError f = do 86 | argument <- getArgumentList 87 | f argument 88 | 89 | 90 | -- | return head 91 | getHead :: Primi 92 | getHead = uses args head 93 | 94 | -- | return whole expression to be evaluated 95 | getExpression :: Primi 96 | getExpression = uses args List 97 | 98 | -- | tag list with same head in the environment 99 | tagHead :: [LispVal] -> Primi 100 | tagHead args = do 101 | h <- getHead 102 | return (List (h:args)) 103 | 104 | -- | return without evaluation 105 | noChange :: Primi 106 | noChange = uses args List 107 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Primitives.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Primitives(primitives) where 2 | 3 | import Eval.Primitive.PrimiFunc 4 | import Data.Environment.EnvironmentType 5 | import Eval.Primitive.Arithmatic.Arithmatic 6 | import Eval.Primitive.List.List 7 | import Eval.Primitive.Compare.Compare 8 | import Eval.Primitive.Logic.Logic 9 | import Eval.Primitive.Control.Branch 10 | import Eval.Primitive.Function.Lambda 11 | import Eval.Primitive.Replace.Replace 12 | import Eval.Primitive.Nest.Nest 13 | import Eval.Primitive.Set.Set 14 | import Eval.Primitive.IO.Print 15 | import Eval.Primitive.InOut.InOut 16 | 17 | 18 | import qualified Data.Text as T 19 | import qualified Data.Map.Strict as M 20 | 21 | -- | Collections of all primitive function 22 | primitives :: M.Map T.Text Primi 23 | primitives = M.fromList 24 | [ ("CompoundExpression",compoundExpressionl) 25 | , ("Minus", minusl) 26 | , ("Divide", dividel) 27 | , ("Plus",plusl) 28 | , ("Times", timesl) 29 | , ("Power", powerl) 30 | , ("Log", logl) 31 | -- list mainpulation 32 | , ("car", carl) 33 | , ("cdr", cdrl) 34 | , ("cons", consl) 35 | , ("Length", lengthl) 36 | , ("Part", partl) 37 | , ("Map", mapl) 38 | , ("Apply",applyl) 39 | -- list construction 40 | , ("Range", rangel) 41 | 42 | -- comparation 43 | , ("Less", lessl) 44 | , ("LessEqual" , lessEquall) 45 | , ("Greater", greaterl) 46 | , ("GreaterEqual", greaterEquall) 47 | , ("Equal", equall) 48 | , ("Inequality",inequalityl) 49 | -- logic function 50 | , ("Not", notl) 51 | , ("And", andl) 52 | , ("Or", orl) 53 | -- branch 54 | , ("If",ifl) 55 | 56 | , ("Function", functionl) 57 | -- replace 58 | , ("Replace", replacel) 59 | , ("ReplaceAll",replaceAlll) 60 | , ("ReplaceRepeated", replaceRepeatedl) 61 | 62 | , ("Nest", nestl) 63 | , ("NestList", nestListl) 64 | 65 | , ("Set",setl) 66 | , ("SetDelayed", setDelayedl) 67 | 68 | , ("Print", printl) 69 | 70 | , ("In", inl) 71 | , ("Out", outl) 72 | 73 | , ("Condition", conditionl) 74 | , ("Pattern", patternl) 75 | ] 76 | 77 | 78 | compoundExpressionl :: Primi 79 | compoundExpressionl = do 80 | many1op 81 | fmap last getArgumentList 82 | 83 | conditionl :: Primi 84 | conditionl = do 85 | withnop 2 86 | noChange 87 | 88 | patternl :: Primi 89 | patternl = do 90 | withnop 2 91 | noChange 92 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Replace/Replace.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Replace.Replace 2 | (-- ^ Replace Functions 3 | replacel,replaceAlll,replaceRepeatedl) where 4 | 5 | import Data.DataType 6 | import Eval.Primitive.Replace.Unpack 7 | import Eval.Primitive.List.Level 8 | import Eval.Primitive.PrimiFunc 9 | import Data.Environment.Environment 10 | import Data.Environment.EnvironmentType 11 | import Data.Environment.Update 12 | import Eval.Patt.PatternPrimi 13 | 14 | import Control.Monad.Except 15 | 16 | replacel, replaceAlll :: Primi 17 | replacel = do 18 | between 2 3 19 | usesArgumentError replacel' 20 | 21 | replaceAlll = do 22 | withnop 2 23 | usesArgumentError replaceAlll' 24 | 25 | 26 | replacel' :: EvalArguments 27 | replacel' (expr:rules:level) = do 28 | unpackedRules <- lift $ unpackReplaceArg rules 29 | levelSpeci <- lift $ unpackLevelSpeci 0 level 30 | levelSpeci (`tryReplaceRuleListP` unpackedRules) expr 31 | 32 | replaceAlll' :: EvalArguments 33 | replaceAlll' [expr,rules] = do 34 | unpackedRules <- lift $ unpackReplaceArg rules 35 | replaceAllP unpackedRules expr 36 | 37 | 38 | -- functions relating with replace repeated feature 39 | replaceRepeatedl :: Primi 40 | replaceRepeatedl = do 41 | withnop 2 42 | usesArgumentError replaceRepeatedl' 43 | -- | Replace until yielding no new result 44 | replaceRepeated :: LispVal -> (LispVal -> Primi) -> Primi 45 | replaceRepeated old replace = do 46 | new <- replace old >>= evaluate 47 | if new == old then 48 | return new 49 | else 50 | replaceRepeated new replace 51 | 52 | replaceRepeatedl' :: [LispVal] -> Primi 53 | replaceRepeatedl' [expr,rules] = do 54 | unpackedRules <- lift $ unpackReplaceArg rules 55 | replaceRepeated expr (replaceAllP unpackedRules) 56 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Replace/Unpack.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Replace.Unpack 2 | (unpackReplaceArg) where 3 | 4 | import Data.DataType 5 | import Data.Environment.EnvironmentType 6 | import Eval.Patt.Regengine 7 | 8 | import qualified Data.Text as T 9 | import Control.Monad.Except 10 | 11 | reps val = Default (tshow val `T.append` " cannot be used for replacing.") 12 | 13 | unpack :: LispVal -> Maybe ParsedRule 14 | unpack (List [Atom "Rule",a,b]) = Just (transformLispPattern a,b) 15 | unpack (List [Atom "RuleDelayed",a,b]) = Just (transformLispPattern a,b) 16 | unpack _ = Nothing 17 | 18 | -- | unpack rule(s) arguemnts in function like Replace, ReplaceAll, etc. 19 | unpackReplaceArg :: LispVal -> IOThrowsError [ParsedRule] 20 | unpackReplaceArg val = 21 | let err = throwError (reps val) 22 | fromUnpackMaybe = maybe err return 23 | in 24 | case val of 25 | List (Atom "List":rules) -> 26 | fromUnpackMaybe (mapM unpack rules) 27 | rule -> fromUnpackMaybe (fmap return (unpack rule)) 28 | -------------------------------------------------------------------------------- /mmaclone/src/Eval/Primitive/Set/Set.hs: -------------------------------------------------------------------------------- 1 | module Eval.Primitive.Set.Set 2 | (setl,setDelayedl) where 3 | 4 | import Data.DataType 5 | import Eval.Primitive.PrimiFunc 6 | import Data.Environment.Environment 7 | import Data.Environment.EnvironmentType 8 | import Data.Environment.Update 9 | import Eval.Patt.Pattern 10 | 11 | import Data.IORef 12 | import Control.Monad 13 | import Control.Monad.IO.Class 14 | import Control.Monad.Trans.Except 15 | import Control.Monad.Except 16 | 17 | 18 | setl :: Primi 19 | setl = do 20 | [lhs, rhs] <- getArgumentList 21 | setVar lhs rhs 22 | return rhs 23 | 24 | setDelayedl :: Primi 25 | setDelayedl = do 26 | setl 27 | return atomNull 28 | 29 | setVar :: Pattern -> LispVal -> StateResult () 30 | setVar lhs rhs = 31 | if validSet lhs then setVariable lhs rhs 32 | else 33 | throwError $ SetError lhs 34 | -------------------------------------------------------------------------------- /mmaclone/src/Parser/NewParse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Parser.NewParse(Expr(..), parseExpr,Stage1,expr) where 3 | 4 | import Text.Parsec hiding (Empty) 5 | import Text.Parsec.String 6 | import qualified Text.Parsec.Token as Token 7 | import Text.Parsec.Language 8 | -- import Control.Applicative((*>)) 9 | import Text.Parsec.Expr 10 | 11 | import Data.Number.Number 12 | import qualified Data.Text as T 13 | 14 | data Expr 15 | = Num Number 16 | | Lis [Expr] 17 | | Args [Expr] 18 | | Var T.Text 19 | | Add Expr Expr 20 | -- | Sub Expr Expr 21 | | Mul Expr Expr 22 | | Pow Expr Expr 23 | -- | Div Expr Expr 24 | | Inverse Expr 25 | -- | Mod Expr Expr 26 | | And Expr Expr 27 | | Or Expr Expr 28 | | Not Expr 29 | | Equal Expr Expr 30 | | Less Expr Expr 31 | | LessEq Expr Expr 32 | | Great Expr Expr 33 | | GreatEq Expr Expr 34 | | UnEq Expr Expr 35 | | Compound Expr Expr-- Expr; Expr 36 | | Apply Expr Expr 37 | | Fact Expr 38 | | Fact2 Expr 39 | | Negate Expr 40 | | Part Expr Expr 41 | | PartArgs [Expr] 42 | | Map Expr Expr 43 | | MapAll Expr Expr 44 | | Apply1 Expr Expr 45 | | Apply11 Expr Expr 46 | | Derivative Int Expr 47 | | Rule Expr Expr 48 | | RuleDelayed Expr Expr 49 | | Replace Expr Expr 50 | | ReplaceRepeated Expr Expr 51 | | Set Expr Expr 52 | | SetDelayed Expr Expr 53 | | Unset Expr 54 | | Dot Expr Expr 55 | | Blk 56 | | BlkE Expr 57 | | BlkSeq 58 | | BlkSeqE Expr 59 | | NullSeq 60 | | NullSeqE Expr 61 | | Pattern Expr Expr 62 | | PatternTest Expr Expr 63 | | Function Expr 64 | | Slot Int 65 | | SlotSeq Int 66 | | Str T.Text 67 | | Chr Char 68 | | Out Int 69 | | None 70 | | Cond Expr Expr 71 | | Alter Expr Expr 72 | deriving (Show,Eq) 73 | 74 | opNames = words ("-> :> && || ! + - * / ; == < <= > >= : @ @@ /@ //@ @@@ \' !! != /. //. = :=" 75 | ++ " // & ? *) (* !! /; : | ^" )-- reserved operations 76 | 77 | lexerConfig = Token.LanguageDef { Token.commentStart = "(*" -- adding comments is easy 78 | , Token.commentEnd = "*)" 79 | , Token.commentLine = "" 80 | , Token.identStart = letter <|> char '$' -- identifiers must start with a letter 81 | , Token.identLetter = alphaNum 82 | , Token.reservedNames = [] 83 | , Token.reservedOpNames = opNames 84 | , Token.opLetter = oneOf "@/=.>!;&" 85 | , Token.caseSensitive = True 86 | , Token.nestedComments = False 87 | , Token.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" 88 | } 89 | 90 | lexer = Token.makeTokenParser lexerConfig 91 | 92 | identifier = Token.identifier lexer -- parses a valid identifier in our language 93 | symbol = Token.symbol lexer -- parses a symbol like "]" 94 | reserved = Token.reserved lexer -- parses a reserved word like "If" 95 | reservedOp = Token.reservedOp lexer -- parses a reserved operation like "<=" 96 | parens = Token.parens lexer -- parses parenthesis surrounding the parser passed to it 97 | brackets = Token.brackets lexer -- parses brackets surrounding the parser passed to it 98 | braces = Token.braces lexer 99 | commaSep = Token.commaSep lexer -- parses some or no comma separated instances of 100 | -- the argument parser 101 | integer = Token.integer lexer -- parses an integer 102 | whiteSpace = Token.whiteSpace lexer -- parses whitespace 103 | 104 | naturalOrFloat = Token.naturalOrFloat lexer 105 | 106 | stringLiteral = Token.stringLiteral lexer 107 | 108 | charLiteral = Token.charLiteral lexer 109 | 110 | natural = Token.natural lexer 111 | 112 | lexeme = Token.lexeme lexer 113 | 114 | semi = Token.semi lexer 115 | 116 | prefix name label = Prefix (reservedOp name *> return label) 117 | 118 | binary name label assoc = Infix (do{ reservedOp name 119 | ; return label 120 | }) assoc 121 | 122 | postfix name label = Postfix (reservedOp name *> return label) 123 | 124 | opTable = [ 125 | [derivative], 126 | -- [function], 127 | [binary "?" PatternTest AssocRight], 128 | [appl,applPart], 129 | -- [postfix "&" Function], 130 | [binary "@" uniapply AssocRight], 131 | [ binary "/@" Map AssocRight, 132 | binary "//@" MapAll AssocRight, 133 | binary "@@" Apply1 AssocRight, 134 | binary "@@@" Apply11 AssocRight 135 | ], 136 | -- [derivative], 137 | 138 | [postfix "!" Fact, 139 | postfix "!!" Fact2], 140 | 141 | [binary "^" Pow AssocRight], 142 | [binary "." Dot AssocLeft], 143 | [ binary "*" Mul AssocLeft 144 | , binary "/" divide AssocLeft 145 | -- , binary "%" Mod AssocLeft, 146 | , spaceMul ] 147 | , [ binary "+" Add AssocLeft 148 | , binary "-" sub AssocLeft 149 | ], 150 | [prefix "-" Negate] 151 | , [ binary "==" Equal AssocLeft 152 | , binary "<" Less AssocLeft 153 | , binary "<=" LessEq AssocLeft 154 | , binary ">" Great AssocLeft 155 | , binary ">=" GreatEq AssocLeft 156 | , binary "!=" UnEq AssocLeft 157 | ] 158 | , [prefix "!" Not] 159 | , [ binary "&&" And AssocLeft ] 160 | , [ binary "||" Or AssocLeft ] 161 | , [binary "|" Alter AssocLeft] 162 | , [binary ":" Pattern AssocLeft] 163 | , [binary "/;" Cond AssocLeft] 164 | , [binary "->" Rule AssocRight, 165 | binary ":>" RuleDelayed AssocRight] 166 | , [binary "/." Replace AssocLeft, 167 | binary "//." ReplaceRepeated AssocLeft] 168 | -- , [function] 169 | , [postfix "&" Function] 170 | , [binary "//" (flip uniapply) AssocLeft] 171 | , [binary "=" Set AssocRight, 172 | binary ":=" SetDelayed AssocRight, 173 | postfix "=." Unset] 174 | 175 | , [binary ";" Compound AssocLeft] 176 | -- , [appl,binary "@" uniapply AssocRight] 177 | ] 178 | 179 | sub e1 e2 = Add e1 (Negate e2) 180 | divide e1 e2 = Mul e1 (Inverse e2) 181 | 182 | uniapply h a = Apply h (Args [a]) 183 | 184 | appl = Infix space AssocLeft 185 | where space = whiteSpace 186 | *> lookAhead (char '[') 187 | *> notFollowedBy (string "[[") 188 | *> return Apply 189 | 190 | 191 | function = Postfix $ 192 | symbol "&" *> notFollowedBy (char '&') *> return Function 193 | 194 | applPart = Infix space AssocLeft 195 | where space = whiteSpace 196 | *> lookAhead (symbol "[[") 197 | *> return Part 198 | 199 | 200 | spaceMul = Infix space AssocLeft 201 | where space = whiteSpace 202 | *> notFollowedBy (choice . map reservedOp $ ("[":opNames)) 203 | *> return Mul 204 | 205 | derivative = Postfix $ do 206 | ps <- many1 (char '\'') 207 | return (Derivative (length ps)) 208 | 209 | opExpr :: Parser Expr 210 | opExpr = buildExpressionParser opTable term 211 | 212 | (<++>) a b = (++) <$> a <*> b 213 | (<:>) a b = (:) <$> a <*> b 214 | 215 | sign ::Parser (Expr -> Expr) 216 | sign = (symbol "-" >> return Negate) 217 | <|> (symbol "+" >> return id) 218 | <|> return id 219 | 220 | number :: Parser Expr 221 | number = do 222 | num <- naturalOrFloat 223 | let numE = case num of 224 | Left a -> Integer a 225 | Right b -> Double b 226 | -- return (s $ Number numE) 227 | return (Num numE) 228 | 229 | list :: Parser Expr 230 | list = Lis <$> braces (commaSep expr) 231 | 232 | 233 | argument :: Parser Expr 234 | argument = 235 | Args <$> brackets (commaSep expr) 236 | 237 | partArgs :: Parser Expr 238 | partArgs = 239 | PartArgs <$> between (symbol "[[") (symbol "]]") (commaSep expr) 240 | 241 | var :: Parser Expr 242 | var = (Var . T.pack) <$> identifier 243 | 244 | stringE :: Parser Expr 245 | stringE = (Str . T.pack) <$> stringLiteral 246 | 247 | charE :: Parser Expr 248 | charE = Chr <$> charLiteral 249 | -- special form ------------------- 250 | atomName :: Parser Expr 251 | atomName = do 252 | c <- letter 253 | cs <- many alphaNum 254 | return $ (Var . T.pack) (c:cs) 255 | 256 | blk :: Parser Expr 257 | blk = string "_" *> return Blk 258 | 259 | blkSeq :: Parser Expr 260 | blkSeq = string "__" *> return BlkSeq 261 | 262 | blkNullSeq :: Parser Expr 263 | blkNullSeq = string "___" *> return NullSeq 264 | 265 | blankE :: Parser Expr -> (Expr -> Expr) -> Parser Expr 266 | blankE p f = do 267 | p 268 | name <- atomName 269 | return (f name) 270 | 271 | pattern :: Parser Expr -> Parser Expr 272 | pattern p = do 273 | name <- atomName 274 | blk <- p 275 | return (Pattern name blk) 276 | 277 | 278 | blks = [blk, blkSeq, blkNullSeq] 279 | 280 | -- blanks = zipWith blank blks [Blk, BlkSeq, NullSeq] 281 | blankEs = zipWith blankE blks [BlkE, BlkSeqE, NullSeqE] 282 | patternBlankEs = map pattern blankEs 283 | patternBlanks = map pattern blks 284 | 285 | specialForms = 286 | let forms = map try (patternBlankEs ++ blankEs ++ reverse blks ++ reverse patternBlanks) in 287 | lexeme $ foldr1 (<|>) forms 288 | -- ------------------------------------------------------------ 289 | -- slot 290 | slot :: Parser Expr 291 | slot = do 292 | char '#' 293 | return (Slot 1) 294 | 295 | slotn :: Parser Expr 296 | slotn = do 297 | char '#' 298 | n <- natural 299 | return (Slot (fromIntegral n)) 300 | 301 | slotSeq :: Parser Expr 302 | slotSeq = do 303 | string "##" 304 | return (SlotSeq 1) 305 | 306 | slotSeqn :: Parser Expr 307 | slotSeqn = do 308 | string "##" 309 | n <- natural 310 | return (SlotSeq (fromIntegral n)) 311 | 312 | slots = 313 | let lis = [slotSeqn, slotSeq, slotn, slot] in 314 | lexeme $ foldr1 (<|>) (map try lis) 315 | ----------------------------------- 316 | -- % Out 317 | out :: Parser Expr 318 | out = do 319 | lis <- many1 (char '%') 320 | return (Out (negate $ length lis)) 321 | 322 | outN :: Parser Expr 323 | outN = do 324 | char '%' 325 | n <- natural 326 | return (Out (fromIntegral n)) 327 | 328 | outTerm = lexeme (try outN <|> try out) 329 | 330 | 331 | 332 | -- ---------------------------------- 333 | 334 | expr :: Parser Expr 335 | expr = 336 | opExpr 337 | <|> term 338 | 339 | term :: Parser Expr 340 | term = specialForms 341 | <|> slots 342 | <|> outTerm 343 | <|> var 344 | <|> number 345 | <|> stringE 346 | <|> charE 347 | <|> try partArgs 348 | <|> argument 349 | <|> list 350 | <|> parens expr 351 | 352 | type Stage1 = Either ParseError Expr 353 | 354 | -- data SemiExpr = Semi Expr | Nosemi Expr 355 | -- 356 | -- fromSemi :: SemiExpr -> Expr 357 | -- fromSemi (Semi e) = e 358 | -- fromSemi (Nosemi e) = e 359 | 360 | -- semiExpr :: Parser SemiExpr 361 | -- semiExpr = do 362 | -- ex <- expr 363 | -- hasSemi <- (semi *> return Semi) <|> return Nosemi 364 | -- return $ hasSemi ex 365 | 366 | -- compoundExpr :: Parser Expr 367 | -- compoundExpr = do 368 | -- semiexs <- many1 semiExpr 369 | -- let exs = map fromSemi semiexs 370 | -- return $ case semiexs of 371 | -- [Nosemi e] -> e 372 | -- _ -> case last semiexs of 373 | -- (Semi _) -> Compound (exs ++ [None]) 374 | -- (Nosemi _) -> Compound exs 375 | 376 | parseExpr = parse (whiteSpace *> expr <* eof) "pass 1" 377 | -------------------------------------------------------------------------------- /mmaclone/src/Parser/Trans.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE ExistentialQuantification #-} 2 | 3 | module Parser.Trans(transform,negateE,inverseE,readExpr) where 4 | 5 | import Data.DataType hiding (addHead) 6 | import Data.Number.Number 7 | import Parser.NewParse 8 | import Control.Monad.Except 9 | import Control.Monad(msum) 10 | import qualified Data.Text as T 11 | 12 | readExpr :: String -> ThrowsError LispVal 13 | readExpr = transform . parseExpr 14 | 15 | transform :: Stage1 -> ThrowsError LispVal 16 | transform (Left err) = throwError $ Parser err 17 | transform (Right expr) = expr2LispVal expr 18 | 19 | expr2LispVal :: Expr -> ThrowsError LispVal 20 | expr2LispVal (Args args) = do 21 | tran <- mapM expr2LispVal args 22 | throwError $ Incomplete tran 23 | 24 | expr2LispVal (PartArgs args) = do 25 | tran <- mapM expr2LispVal args 26 | throwError $ Incomplete tran 27 | 28 | expr2LispVal (Lis lis) = do 29 | tran <- mapM expr2LispVal lis 30 | return $ addHead "List" tran 31 | 32 | expr2LispVal (Add val@(Add _ _) e3) = 33 | flatten val e3 34 | expr2LispVal (Add e1 e2) = 35 | twoArgs (addHead2 "Plus") e1 e2 36 | 37 | expr2LispVal (Mul val@(Mul _ _) e) = 38 | flatten val e 39 | expr2LispVal (Mul e1 e2) = 40 | twoArgs (addHead2 "Times") e1 e2 41 | 42 | expr2LispVal (Pow e1 e2) = 43 | twoArgs (addHead2 "Power") e1 e2 44 | 45 | expr2LispVal (And val@(And _ _) e) = 46 | flatten val e 47 | expr2LispVal (And e1 e2) = 48 | twoArgs (addHead2 "And") e1 e2 49 | 50 | expr2LispVal (Or val@(Or _ _) e) = 51 | flatten val e 52 | expr2LispVal (Or e1 e2) = 53 | twoArgs (addHead2 "Or") e1 e2 54 | 55 | expr2LispVal (Not e) = 56 | oneArg (addHead1 "Not") e 57 | 58 | expr2LispVal (Equal e1 e2) = equalTrans "Equal" e1 e2 59 | expr2LispVal (Less e1 e2) = equalTrans "Less" e1 e2 60 | expr2LispVal (LessEq e1 e2) = equalTrans "LessEqual" e1 e2 61 | expr2LispVal (Great e1 e2) = equalTrans "Greater" e1 e2 62 | expr2LispVal (GreatEq e1 e2) = equalTrans "GreaterEqual" e1 e2 63 | expr2LispVal (UnEq e1 e2) = equalTrans "Unequal" e1 e2 64 | 65 | expr2LispVal (Compound val@(Compound _ _) e) = 66 | flatten val e 67 | expr2LispVal (Compound e1 e2) = 68 | twoArgs (addHead2 "CompoundExpression") e1 e2 69 | 70 | expr2LispVal (Apply h (Args args)) = 71 | listArgs apply h args 72 | 73 | expr2LispVal (Fact e) = 74 | oneArg (addHead1 "Factorial") e 75 | expr2LispVal (Fact2 e) = 76 | oneArg (addHead1 "Factorial2") e 77 | 78 | expr2LispVal (Part h (PartArgs args)) = 79 | listArgs apply' h args 80 | where apply' e es = List $ Atom "Part":e:es 81 | 82 | expr2LispVal (Map e1 e2) = 83 | twoArgs (addHead2 "Map") e1 e2 84 | 85 | expr2LispVal (MapAll e1 e2) = 86 | twoArgs (addHead2 "MapAll") e1 e2 87 | 88 | expr2LispVal (Apply1 e1 e2) = 89 | twoArgs (addHead2 "Apply") e1 e2 90 | 91 | expr2LispVal (Apply11 e1 e2) = 92 | twoArgs apply' e1 e2 93 | where apply' l1 l2 = List [Atom "Apply",l1,l2,list [integer 1]] 94 | 95 | expr2LispVal (Derivative n e) = 96 | let 97 | n' = integer n 98 | deriv l = List [List [Atom "Derivative",n'],l] in 99 | oneArg deriv e 100 | 101 | expr2LispVal (Rule e1 e2) = 102 | twoArgs (addHead2 "Rule") e1 e2 103 | expr2LispVal (RuleDelayed e1 e2) = 104 | twoArgs (addHead2 "RuleDelayed") e1 e2 105 | 106 | expr2LispVal (Replace e1 e2) = 107 | twoArgs (addHead2 "ReplaceAll") e1 e2 108 | expr2LispVal (ReplaceRepeated e1 e2) = 109 | twoArgs (addHead2 "ReplaceRepeated") e1 e2 110 | 111 | expr2LispVal (Set e1 e2) = 112 | twoArgs (addHead2 "Set") e1 e2 113 | expr2LispVal (SetDelayed e1 e2) = 114 | twoArgs (addHead2 "SetDelayed") e1 e2 115 | 116 | expr2LispVal (Unset e) = 117 | oneArg (addHead1 "Unset") e 118 | 119 | expr2LispVal (Dot e1 e2) = 120 | twoArgs (addHead2 "Dot") e1 e2 121 | 122 | expr2LispVal Blk = 123 | return $ List [Atom "Blank"] 124 | expr2LispVal (BlkE e) = 125 | oneArg (addHead1 "Blank") e 126 | 127 | expr2LispVal BlkSeq = 128 | return $ List [Atom "BlankSequence"] 129 | expr2LispVal (BlkSeqE e) = 130 | oneArg (addHead1 "BlankSequence") e 131 | 132 | expr2LispVal NullSeq = 133 | return $ List [Atom "BlankNullSequence"] 134 | expr2LispVal (NullSeqE e) = 135 | oneArg (addHead1 "BlankNullSequence") e 136 | 137 | expr2LispVal (Pattern e1 e2) = 138 | twoArgs (addHead2 "Pattern") e1 e2 139 | 140 | expr2LispVal (PatternTest e1 e2) = 141 | twoArgs (addHead2 "PatternTest") e1 e2 142 | 143 | expr2LispVal (Function e) = 144 | oneArg (addHead1 "Function") e 145 | 146 | expr2LispVal (Cond e1 e2) = 147 | twoArgs (addHead2 "Condition") e1 e2 148 | 149 | expr2LispVal (Alter val@(Alter _ _) e) = 150 | flatten val e 151 | expr2LispVal (Alter e1 e2) = 152 | twoArgs (addHead2 "Alternatives") e1 e2 153 | 154 | expr2LispVal (Negate e) = do 155 | e' <- expr2LispVal e 156 | return $ case e' of 157 | Number n -> Number (- n) 158 | other -> negateE other 159 | 160 | expr2LispVal (Inverse e) = do 161 | e' <- expr2LispVal e 162 | return $ inverseE e' 163 | 164 | 165 | 166 | expr2LispVal other = return $ trivial other 167 | 168 | trivial :: Expr -> LispVal 169 | trivial (Num num) = Number num 170 | trivial (Var name) = Atom name 171 | trivial None = atomNull 172 | trivial (Slot n) = addHead1 "Slot" (integer n) 173 | trivial (SlotSeq n) = addHead1 "SlotSequence" (integer n) 174 | trivial (Str s) = String s 175 | trivial (Chr c) = Char c 176 | trivial (Out n) = addHead1 "Out" (integer n) 177 | -- trivial (Lis lis) = (Atom "List") : lis 178 | 179 | negateE :: LispVal -> LispVal 180 | negateE e = List [Atom "Times", integer (-1), e] 181 | 182 | inverseE :: LispVal -> LispVal 183 | inverseE n = List [Atom "Power", n, integer (-1)] 184 | 185 | -- equal unpacker ----------------------- 186 | unPackEqual (Equal e1 e2) = Just (Equal e1 e2) 187 | unPackEqual _ = Nothing 188 | unPackLess (Less e1 e2) = Just (Less e1 e2) 189 | unPackLess _ = Nothing 190 | unPackLessEq (LessEq e1 e2) = Just (LessEq e1 e2) 191 | unPackLessEq _ = Nothing 192 | unPackGreat (Great e1 e2) = Just (Great e1 e2) 193 | unPackGreat _ =Nothing 194 | unPackGreatEq (GreatEq e1 e2) = Just (GreatEq e1 e2) 195 | unPackGreatEq _ = Nothing 196 | unPackUnEq (UnEq e1 e2) = Just (UnEq e1 e2) 197 | unPackUnEq _ = Nothing 198 | 199 | eqUnpackers = [unPackEqual, unPackLess,unPackLessEq, 200 | unPackGreat,unPackGreatEq,unPackUnEq] 201 | 202 | getEqTrans :: Expr -> Maybe (ThrowsError LispVal) 203 | getEqTrans e = do 204 | expr <- msum $ map ($ e) eqUnpackers 205 | return $ expr2LispVal expr 206 | 207 | equalTrans :: T.Text -> Expr -> Expr -> ThrowsError LispVal 208 | equalTrans name e1 e2 = do 209 | let trans = getEqTrans e1 210 | case trans of 211 | Nothing -> do 212 | e1' <- expr2LispVal e1 213 | e2' <- expr2LispVal e2 214 | return $ List [Atom "Inequality",e1',Atom name,e2'] 215 | (Just e) -> do 216 | tranedE1 <- e 217 | e2' <- expr2LispVal e2 218 | return $ case tranedE1 of 219 | (List lis) -> List (lis ++ [Atom name,e2']) 220 | 221 | -- args transform 222 | addHead :: T.Text -> [LispVal] -> LispVal 223 | addHead na vs = List $ Atom na : vs 224 | 225 | 226 | addHead1 :: T.Text -> LispVal -> LispVal 227 | addHead1 atom v = List [Atom atom,v] 228 | 229 | addHead2 :: T.Text -> LispVal -> LispVal -> LispVal 230 | addHead2 atom v1 v2 = List [Atom atom,v1,v2] 231 | 232 | patternBlk h l = addHead1 "Pattern" (addHead1 h l) 233 | 234 | 235 | oneArg :: (LispVal -> LispVal) -> Expr -> ThrowsError LispVal 236 | oneArg f e = do 237 | e' <- expr2LispVal e 238 | return $ f e' 239 | 240 | 241 | twoArgs :: (LispVal -> LispVal -> LispVal) -> Expr -> Expr 242 | -> ThrowsError LispVal 243 | twoArgs f e1 e2 = do 244 | e1' <- expr2LispVal e1 245 | e2' <- expr2LispVal e2 246 | return $ f e1' e2' 247 | 248 | listArgs :: (LispVal -> [LispVal] -> LispVal) -> Expr -> [Expr] 249 | -> ThrowsError LispVal 250 | listArgs f e es = do 251 | e' <- expr2LispVal e 252 | es' <- mapM expr2LispVal es 253 | return $ f e' es' 254 | 255 | 256 | 257 | apply :: LispVal -> [LispVal] -> LispVal 258 | apply = (List.) . (:) 259 | ----------------------------------------------- 260 | 261 | -- flatten transform 262 | flatten :: Expr -> Expr -> ThrowsError LispVal 263 | flatten val e3 = do 264 | trans <- expr2LispVal val 265 | e3' <- expr2LispVal e3 266 | return $ case trans of 267 | List lis -> List (lis ++ [e3']) 268 | -------------------------------------------------------------------------------- /mmaclone/src/Show/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Show.Pretty(prettyPrint,showLispVal,printLispVal) where 2 | import Data.DataType 3 | import Data.Number.Number 4 | import Data.List 5 | import qualified Data.Text.IO as T 6 | import qualified Data.Text as T 7 | 8 | precedence :: [(T.Text, Int)] 9 | precedence = [ 10 | ("Power", 1), 11 | ("Times",2), 12 | ("Plus", 3), 13 | ("Set", 4), 14 | ("SetDelayed", 5) 15 | ] 16 | 17 | leastPre :: Int 18 | leastPre = 6 19 | 20 | infixForm :: T.Text -> T.Text 21 | infixForm "Set" = "=" 22 | infixForm "SetDelayed" = ":=" 23 | infixForm "Times" = " " 24 | infixForm "Plus" = "+" 25 | infixForm "Power" = "^" 26 | infixForm x = x 27 | 28 | getPrecedence :: T.Text -> Maybe Int 29 | getPrecedence = flip lookup precedence 30 | 31 | prettyPrint :: LispVal -> T.Text 32 | prettyPrint = prettyPrint' leastPre 33 | 34 | prettyPrint' :: Int -> LispVal -> T.Text 35 | prettyPrint' _ (List (Atom "List" : xs)) = 36 | let args = map prettyPrint xs in 37 | curlyBrack $ T.intercalate "," args 38 | 39 | prettyPrint' now (List (Atom "Times" : Number (Integer (-1)): xs)) = 40 | '-' `T.cons` prettyPrint' now (List (Atom "Times" : xs)) 41 | 42 | 43 | prettyPrint' now (List (Atom name : xs)) = 44 | let prec = getPrecedence name in 45 | case prec of 46 | Nothing -> functionWrap name (map prettyPrint xs) 47 | Just n -> 48 | let args = map (prettyPrint' n) xs 49 | form = infixForm name 50 | result = addInfix form args in 51 | if now <= n then bracket result else result 52 | prettyPrint' _ x = tshow x 53 | 54 | encloseWith :: T.Text -> T.Text -> T.Text -> T.Text 55 | encloseWith a b c = T.concat [a, c, b] 56 | 57 | bracket :: T.Text -> T.Text 58 | bracket = encloseWith "(" ")" 59 | 60 | curlyBrack :: T.Text -> T.Text 61 | curlyBrack = encloseWith "{" "}" 62 | 63 | functionWrap :: T.Text -> [T.Text] -> T.Text 64 | functionWrap fun args = encloseWith (fun `T.append` "[") "]" (T.intercalate "," args) 65 | 66 | checkMinus :: T.Text -> Bool 67 | checkMinus s 68 | | T.head s == '-' = True 69 | | otherwise = False 70 | 71 | addInfix :: T.Text -> [T.Text] -> T.Text 72 | addInfix "+" xs = addInfixRule checkMinus id "+" xs 73 | addInfix "^" xs = addInfixRule checkMinus (T.cons '^' . bracket) "^" xs 74 | addInfix sym xs = T.intercalate sym xs 75 | 76 | addInfixRule :: (T.Text -> Bool) -> (T.Text -> T.Text) 77 | -> T.Text -> [T.Text] -> T.Text 78 | addInfixRule _ _ _ [] = "" 79 | addInfixRule _ _ _ [x] = x 80 | addInfixRule check rule syb (x1:res@(x2:_)) 81 | | check x2 = x1 `T.append` rule (addInfixRule check rule syb res) 82 | | otherwise = x1 `T.append` syb `T.append` addInfixRule check rule syb res 83 | 84 | showLispVal (List [Atom "FullForm",val]) = fullForm val 85 | showLispVal val = prettyPrint val 86 | 87 | printLispVal = T.putStrLn . showLispVal 88 | -------------------------------------------------------------------------------- /mmaclone/src/Test.hs: -------------------------------------------------------------------------------- 1 | module Test where 2 | import Data.Number.Number hiding(plus,times,one) 3 | import Data.DataType hiding (list,addHead) 4 | import Parser.Trans 5 | import Eval.Eval 6 | 7 | import Data.Environment.Environment 8 | import Control.Monad.Except 9 | import Control.Monad.Trans.State 10 | 11 | 12 | import System.IO.Unsafe 13 | 14 | addHead a b = List (Atom a : b) 15 | 16 | list = addHead "List" 17 | 18 | plus = addHead "Plus" 19 | 20 | times = addHead "Times" 21 | 22 | comp = addHead "CompoundExpression" 23 | 24 | part = addHead "Part" 25 | 26 | map' = addHead "Map" 27 | mapAll = addHead "MapAll" 28 | apply = addHead "Apply" 29 | apply1 [l1,l2] = apply [l1,l2,list [one]] 30 | 31 | replace = addHead "ReplaceAll" 32 | replaceR = addHead "ReplaceRepeated" 33 | rule = addHead "Rule" 34 | ruleD = addHead "RuleDelayed" 35 | 36 | set = addHead "Set" 37 | setD = addHead "SetDelayed" 38 | 39 | unset = addHead "Unset" . return 40 | 41 | fun = addHead "Function" 42 | slot = addHead "Slot" . return 43 | s1 = slot one 44 | s2 = slot two 45 | ss1 = addHead "SlotSequence" [one] 46 | 47 | cond = addHead "Condition" 48 | 49 | deriv n l = List [List [Atom "Derivative", integer n],l] 50 | 51 | fact = addHead "Factorial" . return 52 | fact2 = addHead "Factorial2" . return 53 | 54 | patt = addHead "Pattern" 55 | pattT = addHead "PatternTest" 56 | blk = List [Atom "Blank"] 57 | 58 | andE = addHead "And" 59 | orE = addHead "Or" 60 | notE = addHead "Not" 61 | ineq = addHead "Inequality" 62 | 63 | dot = addHead "Dot" 64 | 65 | alter = addHead "Alternatives" 66 | 67 | equal = Atom "Equal" 68 | less = Atom "Less" 69 | lessEq = Atom "LessEqual" 70 | great = Atom "Greater" 71 | greatEq = Atom "GreaterEqual" 72 | unEq = Atom "Unequal" 73 | 74 | one = integer 1 75 | two = integer 2 76 | three = integer 3 77 | 78 | pe = Atom "P" 79 | 80 | rational = Number . Rational 81 | 82 | readVal = extractValue . readExpr 83 | 84 | testEvalWith :: (LispVal -> Primi) -> String -> LispVal 85 | testEvalWith eval expr = 86 | let val = readVal expr 87 | evaled = unsafePerformIO.runExceptT $ evalStateT (eval val) initialState in 88 | extractValue evaled 89 | 90 | testEvalOnce = testEvalWith eval' 91 | runEval = testEvalWith eval 92 | -------------------------------------------------------------------------------- /mmaclone/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-5.2 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /mmaclone/test/Data/Number/NumberSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Number.NumberSpec where 2 | 3 | import Data.Number.Number 4 | import Data.Ratio 5 | import Test.Hspec 6 | 7 | i1 = 3 8 | i2 = 4 9 | i3 = -4 10 | 11 | int1 = Integer i1 12 | int2 = Integer i2 13 | int3 = Integer i3 14 | 15 | d1 = 3.0 16 | d2 = 2.0 17 | d3 = -4.0 18 | 19 | dou1 = Double d1 20 | dou2 = Double d2 21 | dou3 = Double d3 22 | 23 | r1 = 1 % 3 24 | r2 = 3 % 5 25 | r3 = negate 4 % 7 26 | 27 | ra1 = Rational r1 28 | ra2 = Rational r2 29 | ra3 = Rational r3 30 | 31 | int = Just . Integer 32 | dou = Just . Double 33 | ra = Just . Rational 34 | 35 | spec :: Spec 36 | spec = do 37 | describe "power evaluation" $ do 38 | context "raise int to int" $ do 39 | it "positive exponent" $ do 40 | powerN int1 int2 == int (i1 ^ i2) 41 | it "negative exponet" $ do 42 | powerN int1 int3 == ra ((1 % i1) ^ (negate i3)) 43 | 44 | context "rational number" $ do 45 | it "rational base to int exp" $ do 46 | powerN ra1 int1 == ra (r1 ^ i1) 47 | it "negative exponent" $ do 48 | powerN ra1 int3 == ra ((1 / r1) ^ negate i3) 49 | 50 | context "rational exponent" $ do 51 | it "return nothing" $ do 52 | powerN int1 ra1 == Nothing 53 | 54 | context "double involved" $ do 55 | it "double exponent" $ do 56 | powerN ra1 dou1 == dou (fromRational r1 ** d1) 57 | it "double base" $ do 58 | powerN dou1 int3 == dou (d1 ** fromIntegral i3) 59 | 60 | -- describe "" 61 | -------------------------------------------------------------------------------- /mmaclone/test/Eval/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | module Eval.EvalSpec where 2 | 3 | import Data.Environment.Environment 4 | import Eval.Eval 5 | import Data.DataType hiding (list) 6 | import Parser.Trans 7 | import Test 8 | import Data.Ratio 9 | import Data.Number.Number hiding(plus,times,one,less,lessEqual,greater,greaterEqual,equal) 10 | import System.IO.Unsafe 11 | import Control.Monad.Except 12 | import Control.Monad.Trans.State 13 | 14 | import Test.Hspec 15 | -- import Test.QuickCheck 16 | -- import Control.Exception(evaluate) 17 | 18 | 19 | test1 = test . return 20 | 21 | test a b = 22 | let parsed = extractValue $ mapM readExpr a in 23 | testEval parsed `shouldBe` b 24 | 25 | test2 a b = test1 a (readVal b) 26 | 27 | test3 a b = test a (readVal b) 28 | 29 | testEval :: [LispVal] -> LispVal 30 | testEval exprs = 31 | let expr = mapM eval exprs 32 | evaled = runExceptT $ evalStateT expr initialState in 33 | last (extractValue (unsafePerformIO evaled)) 34 | 35 | -- double :: Double -> LispVal 36 | -- double = Number . Double 37 | 38 | spec :: Spec 39 | spec = do 40 | describe "testEvaluate a LispVal" $ do 41 | context "number evaluation" $ do 42 | it "plus" $ do 43 | test1 "1+2+3+4" $ (integer 10) 44 | test2 "x+x+x" "3 x" 45 | test2 "x+2x+y+3x" "y+6x" 46 | test2 "f[x]+2f[x]+g[x]+f[x]" "4f[x]+g[x]" 47 | it "times" $ do 48 | test2 "x x x" "x^3" 49 | test2 "x^2 y x" "y x^3" 50 | test2 "x^2+x^3+x^6+x^2" "x^3+x^6+2x^2" 51 | it "subtract" $ do 52 | test1 "3-2.0" (double 1.0) 53 | it "divide" $ do 54 | test1 "2/3" (rational $ 2 % 3) 55 | it "unesscary rational number" $ do 56 | test1 "3/2*2" (integer 3) 57 | 58 | it "power evaluation" $ do 59 | test1 "3^(-2)" (rational (1 % 9)) 60 | 61 | -- -- context "head test" $ do 62 | -- -- it "test string" $ do 63 | -- -- test1 "(string? \"sdf\")" Bool True 64 | 65 | context "recursive" $ do 66 | it "recursive exp" $ do 67 | test1 "1+4/2+2*3" (integer 9) 68 | it "recursive" $ do 69 | test1 "3 2 4 4/9" (rational $ 32 % 3) 70 | 71 | context "undefined symbol" $ do 72 | it "undefined symbol" $ do 73 | test1 "xyz[1+2,3]" $ List [Atom "xyz", (Number . Integer) 3, 74 | (Number . Integer) 3] 75 | test1 "a 3" $ List [Atom "Times", Number $ Integer 3, Atom "a"] 76 | -- it "merge same head" $ do 77 | -- test1 "x*x*2" $ List [Atom "Times", integer 2, List [Atom "Power", Atom "x",integer 2]] 78 | 79 | context "sequence" $ do 80 | it "expand sequence" $ do 81 | test1 "f[x,Sequence[y,y]]" $ List [Atom "f", Atom "x", Atom "y", Atom "y"] 82 | 83 | context "lisp mainpulation" $ do 84 | context "length" $ do 85 | it "evaluate length of a lispval" $ do 86 | test1 "Length@{23, 3 ,2, \"sdf\" ,3/2}" $ integer 5 87 | it "length of an atom value" $ do 88 | test1 "Length@(1-2)" $ integer 0 89 | 90 | context "Eval.Primitive.Primi.List.Part" $ do 91 | context "part" $ do 92 | it "part of a list,index from 0" $ do 93 | test1 "{1,2,3,4}[[4]]" $ integer 4 94 | it "arbitrary nest" $ do 95 | test1 "{{1, 2, 3}, {2, 3}, 3, 4}[[{2, 1}, {1, 2}]]" $ list [list [integer 2,integer 3],list [integer 1,integer 2]] 96 | test1 "{{1,2},{3,4,5}}[[2,1]]" $ integer 3 97 | test1 "(1+2x+3)[[1]]" $ integer 4 98 | 99 | context "Eval.Primitive.Primi.List.Cons" $ do 100 | context "Range" $ do 101 | it "different argumens" $ do 102 | test1 "Range[1,2,1]" $ list [one,two] 103 | test1 "Range[3]" $ list [one,two,three] 104 | test1 "Range[1,1.1,0.1]" $ list [double 1, double 1.1] 105 | test1 "Range[1,1+1/2,1/2]" $ list [integer 1,rational (3%2)] 106 | 107 | context "Eval.Primitive.Primi.List.Elem" $ do 108 | context "car" $ do 109 | it "return first element" $ do 110 | test1 "car[{1,2,3}]" (Atom "List") 111 | context "cdr" $ do 112 | it "return the rest elements" $ do 113 | test1 "cdr[{1,2}]" (List [integer 1, integer 2]) 114 | context "cons" $ do 115 | it "cons" $ do 116 | test1 "cons[1,{1,2}]" (List [one,Atom "List",one,two]) 117 | 118 | context "Eval.Primitive.Primi.List.Map" $ do 119 | context "map" $ do 120 | it "level 1" $ do 121 | test1 "P/@{1,2,3}" (readVal "{P[1],P[2],P[3]}") 122 | test1 "Map[f,{1,2,3}]" (readVal "{f[1],f[2],f[3]}") 123 | it "other level" $ do 124 | test1 "Map[f,{1,2,{3}},2]" (readVal "{f[1],f[2],f[{f[3]}]}") 125 | test1 "Map[f,{1,2,{3}},{2}]" (readVal "{1,2,{f[3]}}") 126 | test1 "Map[f,{1,{{2},3}},{2,3}]" (readVal "{1,{f[{f[2]}],f[3]}}") 127 | 128 | context "apply" $ do 129 | it "level 0" $ do 130 | test1 "f@@{1,2,3}" (readVal "f[1,2,3]") 131 | test1 "Apply[f,{1,2,3},{0}]" (readVal "f[1,2,3]") 132 | it "other level" $ do 133 | test1 "Apply[f,{1,{2,{3}}},2]" (readVal "{1,f[2,f[3]]}") 134 | test1 "f@@@{1,{2},3}" (readVal "{1,f[2],3}") 135 | test1 "Apply[f,{1,{2,{3}}},{2}]" (readVal "{1,{2,f[3]}}") 136 | test1 "Apply[f,{1,{2,{3}}},{0,1}]" (readVal "f[1,f[2,{3}]]") 137 | 138 | 139 | -- 140 | context "Eval.Primitive.Primi.Compare" $ do 141 | context "compare number" $ do 142 | it "compare" $ do 143 | test1 "Less[1,2.1,3,4]" true 144 | test1 "Less[1/2,3,2]" false 145 | it "inequality" $ do 146 | test1 "1==1==a" (readVal "1==a") 147 | test1 "1>2<3=2<=2.0>=1.0" (readVal "a3.1" false 150 | test1 "1!=2!=3" true 151 | test1 "1!=1==3" false 152 | 153 | context "Eval.Logic.Logic" $ do 154 | context "&&" $ do 155 | it "True" $ do 156 | test1 "True&&True" true 157 | it "False" $ do 158 | test1 "False && False" false 159 | test2 "a&&b&&True&&1!=1.0" "False" 160 | test2 "a&&1==1&&2==2" "a" 161 | context "||" $ do 162 | it "case #t #f" $ do 163 | test1 "True||False||a" true 164 | test2 "b||False || False||a" "b||a" 165 | test2 "a||1==2||2==1.0||2!=2.0" "a" 166 | context "!" $ do 167 | it "case #t" $ do 168 | test1 "!True" false 169 | 170 | context "Eval.Primi.Control.Branch" $ do 171 | context "If" $ do 172 | it "If expression" $ do 173 | test1 "If[True,1,2]" (readVal "1") 174 | test1 "If[False,1,2]" (readVal "2") 175 | test1 "If[1,2,3,4]" (readVal "4") 176 | 177 | context "Eval.Primi.Primi" $ do 178 | context "CompoundExpression" $ do 179 | it "return last value" $ do 180 | test1 "a;b;c;1" one 181 | test2 "a;b;c" "c" 182 | 183 | context "Eval.Lambda" $ do 184 | context "slot type" $ do 185 | it "slot slotsequence" $ do 186 | test2 "({#1,Plus[##2]}&) @@@(Range/@Range[2,3])" "{{1,2},{1,5}}" 187 | test2 "(#[[1]]+#[[2]]&) /@{{1,2},{3,4,5},{6,7}}" "{3,7,13}" 188 | test2 "((#+##&) @@#&) /@{{1,2},{2,2,2},{3,4}}" "{4,8,10}" 189 | context "explicit Function" $ do 190 | it "Function" $ do 191 | test2 "Function[{x,y},x y][2,3]" "6" 192 | test2 "Function[x,2 x][5]" "10" 193 | test2 "(Function@@{{x},x==2})[2]" "True" 194 | 195 | context "Eval.Primitive.Primi.Replace.Replace" $ do 196 | context "Replace" $ do 197 | it "replace at different level" $ do 198 | test2 "Replace[x,x -> 1]" "1" 199 | test2 "Replace[{x,y},x -> 1]" "{x,y}" 200 | test2 "Replace[{x,y},{_,_} -> 1]" "1" 201 | test2 "Replace[{x,y,z},x -> 1,1]" "{1,y,z}" 202 | test2 "Replace[{{x},x,{{x}}},x -> 1,2]" "{{1},1,{{x}}}" 203 | test2 "Replace[{x,{x}},x -> 1,{2}]" "{x,{1}}" 204 | test2 "Replace[{x,x[x]},x -> 1,2]" "{1,x[1]}" 205 | 206 | context "ReplaceAll" $ do 207 | it "ReplaceAll" $ do 208 | test2 "{x,y,z}/.x -> 1" "{1,y,z}" 209 | test2 "{x[x],y}/.x -> 1" "{1[1],y}" 210 | test2 "{{x,y}}/.x:>Sequence[2,3]" "{{2,3,y}}" 211 | test2 "{{x,y},y}/.{_,_} -> {1,1}" "{1,1}" 212 | 213 | context "ReplaceRepeated" $ do 214 | it "ReplaceRepeated" $ do 215 | test2 "f[g[x],y]//.{f[x_,y_]:>k[g[x],g[y]],g[g[x_]]:>g[x]}" "k[g[x],g[y]]" 216 | test2 "x//.x -> 1" "1" 217 | 218 | context "eval with context" $ do 219 | it "single value" $ do 220 | test ["a=3", "a"] $ integer 3 221 | test ["a=3", "b[2]=4","a+b[2]"] (integer 7) 222 | it "factorial" $ do 223 | test ["fact[n_]:=n fact[n-1]", 224 | "fact[0]=1","1==2&&fact[1000000]","fact[10]"] (integer 3628800) 225 | it "fibonacci" $ do 226 | test 227 | ["fib[n_]:=fib[n]=fib[n-1]+fib[n-2]", 228 | "fib[1]=1;fib[2]=1", "fib[40]"] 229 | (integer 102334155) 230 | 231 | context "Nest,NestList" $ do 232 | context "Nest" $ do 233 | it "nest a fucntion" $ do 234 | test ["f[x_]=x^2","Nest[f,2,3]"] (integer 256) 235 | test2 "Nest[f,x,4]" "f[f[f[f[x]]]]" 236 | context "NestList" $ do 237 | it "Nestlist" $ do 238 | test2 "NestList[f,x,3]" "{x,f[x],f[f[x]],f[f[f[x]]]}" 239 | test2 "NestList[f,x,10][[{2,4},1]]" "{x,f[f[x]]}" 240 | 241 | it "pattern matching" $ do 242 | test 243 | ["a[0]=1","a[0.0]=1","a[0]","a[0.0]"] (integer 1) 244 | it "pattern test" $ do 245 | test 246 | ["f[a_]=a","f[a_?(#>10&)]=10", "f[1100]"] (integer 10) 247 | test 248 | ["12/.x_?(#>111&)->1"] (integer 12) 249 | test3 250 | ["f[a_?(False&)]=100", "f[1000]"] "f[1000]" 251 | test 252 | ["fib[n_]:=fib[n]=fib[n-1]+fib[n-2]", 253 | "fib[n_?(#==1&)]=1", "fib[n_?(#==2&)]=1", "fib[40]"] 254 | (integer 102334155) 255 | test 256 | ["zero[_]=False","zero[0]=True", 257 | "f[_]=19","f[_?zero]=100", "f[0]"] (integer 100) 258 | 259 | test 260 | ["f[x_, x_] = 100", "f[1,1]"] (integer 100) 261 | test3 262 | ["f[x_, x_]= 100", "f[1,2]"] "f[1,2]" 263 | test3 264 | ["{1,2,3}/.{x_,x_,y_} -> 2"] "{1,2,3}" 265 | test 266 | ["{1,1,2}/.{x_,x_,y_} -> 2"] (integer 2) 267 | test 268 | ["{1,1,2,2,3}/.{x_,x_,y_,y_,z_} -> 2"] (integer 2) 269 | 270 | test3 271 | ["{{1,1},{0,0},{0,2}}/.{x_,y_}/;x+y==2 -> a"] "{a,{0,0},a}" 272 | test3 273 | ["{{1,1},{0,0},{0,2}}/.{x_,x_}/;x+x==2 -> a"] "{a,{0,0},{0,2}}" 274 | test3 275 | ["Condition[Condition[f[x_],x>1],x<2]=sdf","f[3/2]"] "sdf" 276 | test3 277 | ["Condition[Condition[f[x_],x>1],x<2]=sdf","f[0]"] "f[0]" 278 | test3 279 | ["Condition[Condition[f[x_],x>1],x<2]=sdf","f[2]"] "f[2]" 280 | test3 281 | ["q[i_,j_]:=q[i,j]=q[i-1,j]+q[i,j-1];q[i_,j_]/;i<0||j<0=0;q[0,0]=1" 282 | ,"q[5,5]"] "252" 283 | it "sequence test" $ do 284 | -- Tests for sequence !!! 285 | test3 ["{1,2,3}/.{x__,y_} -> y"] "3" 286 | test3 ["f[x_,y__,z_]=Plus[x,y,z]", "f[1,2,3,4,5]"] "15" 287 | test3 ["f[a_*b__]:=f[a]+Sequence@@(Map[f,{b}])", "f[x y z k l]"] 288 | "f[k]+f[l]+f[x]+f[y]+f[z]" 289 | test3 ["f[x__] := Length[{x}]", "{f[x, y, z], f[]}"] 290 | "{3,f[]}" 291 | test3 ["f[x___] := p[x, x]","{f[], f[1], f[1, a]}"] 292 | "{p[],p[1,1],p[1,a,1,a]}" 293 | test3 ["f[x___]:=p[x,Plus[x]]", "{f[1], f[1,2],f[1,2,x],f[1,2,3]}"] 294 | "{p[1,1],p[1,2,3],p[1,2,x,3+x],p[1,2,3,6]}" 295 | test3 ["f[x_,y___]:=Plus[y]^x", "{f[1,2,3], f[23,5,2], f[23,af,23,l],f[]}"] 296 | "{5,27368747340080916343,(23+af+l)^23,f[]}" 297 | test3 ["f[a, b, c] /. f[x__] -> p[x, x, x]"] "p[a,b,c,a,b,c,a,b,c]" 298 | test3 ["h[a___, x_, b___, x_, c___] := hh[x] h[a, b, c]","h[2, 3, 2, 4, 5, 3]"] "h[4,5] hh[2] hh[3]" 299 | test3 300 | ["patt={x___,y_,z_,e___}/;y>z -> {x,z,y,e} ","{12,1,4,2,6,8,3,1,3456,12,6,1,43,1}//.patt"] 301 | "{1,1,1,1,2,3,4,6,6,8,12,12,43,3456}" 302 | 303 | it "alternative test" $ do 304 | test3 ["{a, b, c, d, a, b, b, b} /. a | b -> x"] "{x,x,c,d,x,x,x,x}" 305 | 306 | it "head test" $ do 307 | test3 ["f[x_g]=g","{f[g[2]], f[2]}"] "{g,f[2]}" 308 | test3 ["f[x_Integer]=int", "{f[2], f[2.0],f[g]}"] "{int,f[2.0],f[g]}" 309 | test3 ["f[x_Symbol]=sym", "{f[2], f[a], a=1;f[a]}"] "{f[2],sym,f[1]}" 310 | 311 | it "sequence head test" $ do 312 | test3 ["f[x__Integer]=2", "{f[2,3],f[a,2],f[2,a],f[2]}"] "{2,f[a,2],f[2,a],2}" 313 | test3 ["f[x__Real] := Plus[x]/Length[{x}]", "{f[1.0,4.0],f[2,2],f[1.0,a]}"] "{2.5,f[2,2],f[1.0,a]}" 314 | 315 | it "sequence pattern test" $ do 316 | test3 ["f[___,y__?(#>2&)]={y}", "{f[2,3],f[1,1,1,2],f[112,1,1,3,4]}"] "{{3},f[1,1,1,2],{3,4}}" 317 | 318 | 319 | 320 | it "symbolic manipulation" $ do 321 | test3 322 | ["rules = {Log[x_ y_] :> Log[x] + Log[y], Log[x_^k_] :> k Log[x]}", 323 | "Log[a (b c^d)^e] //. rules"] "Log[a]+e (Log[b]+d Log[c])" 324 | test3 325 | ["{f[f[x]], f[x], g[f[x]], f[g[f[x]]]} //. f[x_] -> x"] "{x,x,g[x],g[x]}" 326 | 327 | it "derivative" $ do 328 | test3 329 | ["D[a_,x_]=0","D[x_,x_]:=1", "D[a_+b__,x_]:=D[a,x]+D[Plus[b],x]", 330 | "D[a_ b__,x_]:=D[a,x] b+a D[Times[b],x]", 331 | "D[a_^(b_), x_]:= a^b(D[b,x] Log[a]+D[a,x]/a b)", 332 | "D[Log[a_], x_]:= D[a, x]/a", 333 | "D[Sin[a_], x_]:= D[a,x] Cos[a]", 334 | "D[Cos[a_], x_]:=-D[a,x] Sin[a]","D[x/Sin[x]/Cos[x]^2,x]"] 335 | "Plus[Times[x,Plus[Times[-1,Power[Cos[x],-1],Power[Sin[x],-2]],Times[2,Power[Cos[x],-3]]]],Times[Power[Cos[x],-2],Power[Sin[x],-1]]]" 336 | 337 | 338 | main = hspec spec 339 | -------------------------------------------------------------------------------- /mmaclone/test/Parser/NewParseSpec.hs: -------------------------------------------------------------------------------- 1 | module Parser.NewParseSpec where 2 | 3 | import Parser.NewParse 4 | import Data.Number.Number 5 | 6 | import Text.Parsec 7 | import Test.Hspec 8 | import Test.QuickCheck hiding (Args) 9 | import Control.Exception(evaluate) 10 | 11 | extractValue (Right a) = a 12 | 13 | testRead = extractValue . parseExpr 14 | 15 | 16 | test a b = testRead a `shouldBe` b 17 | 18 | testApply a b c = test a $ Apply (Var b) (Args c) 19 | 20 | integer = Num . Integer 21 | double = Num . Double 22 | 23 | preS = "F[a,b,c]" 24 | pre = Apply (Var "F") (Args [Var "a", Var "b", Var "c"]) 25 | 26 | pe = Var "P" 27 | 28 | spec :: Spec 29 | spec = do 30 | describe "testRead parse a string to LispVal" $ do 31 | context "when provided atom" $ do 32 | it "read an atom expression" $ do 33 | test "abc" $ Var "abc" 34 | -- test "True" true 35 | -- test "False" false 36 | test "111" (integer 111) 37 | test "23.6" (double 23.6) 38 | test "23.6e5" (double 23.6e5) 39 | test "-32" $ Negate (integer 32) 40 | context "parse expression with arguments" $ do 41 | it "prefix form" $ do 42 | testApply "P[]" "P" [] 43 | testApply "P []" "P" [] 44 | testApply "P [a, b]" "P" [Var "a", Var "b"] 45 | testApply "P [B [a], 23]" "P" [Apply (Var "B") (Args [Var "a"]) ,integer 23] 46 | context "part expression" $ do 47 | it "part expression" $ do 48 | test "P[[a]]" (Part pe (PartArgs [Var "a"])) 49 | test "P[[P[x],a]]" (Part pe (PartArgs [Apply pe (Args [Var "x"]),Var "a"])) 50 | context "operator" $ do 51 | it "@ function apply" $ do 52 | test "P@c" (Apply pe (Args [Var "c"])) 53 | test "P@P@P" (Apply pe (Args $ [Apply pe (Args [pe])])) 54 | it "// apply" $ do 55 | test "P//p" (Apply (Var "p") (Args [pe])) 56 | test "P//p//a" (Apply (Var "a") (Args [Apply (Var "p") (Args [pe])])) 57 | it "/@ map" $ do 58 | test "P/@P" (Map pe pe) 59 | test "P/@P@c" (Map pe (Apply pe (Args [Var "c"]))) 60 | it "@@ apply" $ do 61 | test "P@@P" (Apply1 pe pe) 62 | it "derivative" $ do 63 | test "P''[x]" (Apply (Derivative 2 pe) $ Args [Var "x"]) 64 | -- test "P'" 65 | it "dot" $ do 66 | test "P . P" (Dot pe pe) 67 | 68 | it "not factorial" $ do 69 | test "!a" (Not (Var "a")) 70 | test "a!" (Fact (Var "a")) 71 | 72 | it "replace /." $ do 73 | test "P/.P->P" (Replace pe (Rule pe pe)) 74 | test "P/.{P->P, P->P}" (Replace pe (Lis [Rule pe pe,Rule pe pe])) 75 | 76 | it "& function" $ do 77 | test "P&" (Function pe) 78 | test "(P&) @P" (Apply (Function pe) (Args [pe])) 79 | context "parse string" $ do 80 | it "read a common string" $ do 81 | test "\"a string\"" $ Str "a string" 82 | it "with standard" $ do 83 | test "\"\\n\\t\\\"\\\\\"" $ Str "\n\t\"\\" 84 | context "parse a literal char" $ do 85 | it "read a char" $ do 86 | test "\'c\'" $ Chr 'c' 87 | test "\'\\n\'" $ Chr '\n' 88 | context "parse blank pattern" $ do 89 | it "blank pattern" $ do 90 | test "_" Blk 91 | test "_P" (BlkE pe) 92 | test "P_P" (Pattern pe (BlkE pe)) 93 | test "__" BlkSeq 94 | test "__P" (BlkSeqE pe) 95 | test "P__P" (Pattern pe (BlkSeqE pe)) 96 | test "___" NullSeq 97 | test "___P" (NullSeqE pe) 98 | test "P___P" (Pattern pe (NullSeqE pe)) 99 | test "_[P]" $ Apply Blk (Args [pe]) 100 | context "# slot" $ do 101 | it "slot" $ do 102 | test "#" (Slot 1) 103 | test "#2" (Slot 2) 104 | test "1+#" (Add (integer 1) (Slot 1)) 105 | it "slot sequence" $ do 106 | test "##" (SlotSeq 1) 107 | test "##6" (SlotSeq 6) 108 | test "P@@##" (Apply1 pe (SlotSeq 1)) 109 | context "% Out" $ do 110 | it "% Out" $ do 111 | test "%" (Out (-1)) 112 | test "%%" (Out (-2)) 113 | test "%4" (Out 4) 114 | test "P[%]" (Apply pe (Args [Out (-1)])) 115 | test "#%" (Mul (Slot 1) (Out (-1))) 116 | 117 | context "compound expression" $ do 118 | it "compound" $ do 119 | test "P;#" (Compound pe (Slot 1)) 120 | -- test "P;1;2" (Compound [pe,integer 1,integer 2, None]) 121 | 122 | context "conditional expression" $ do 123 | it "condtion" $ do 124 | test "P_ -> 1/;P" (Rule (Pattern pe Blk) (Cond (integer 1) pe)) 125 | test "P=1/;P" (Set pe (Cond (integer 1) pe)) 126 | 127 | context "pattern alternative" $ do 128 | it ": pattern" $ do 129 | test "P:_" (Pattern pe Blk) 130 | test "P:(1|2)" (Pattern pe (Alter (integer 1) (integer 2))) 131 | 132 | main = hspec spec 133 | -------------------------------------------------------------------------------- /mmaclone/test/Parser/TransSpec.hs: -------------------------------------------------------------------------------- 1 | module Parser.TransSpec where 2 | 3 | import Parser.Trans 4 | import Parser.NewParse 5 | import Data.Number.Number hiding(plus,times,one,less,lessEqual,greater,greaterEqual,equal) 6 | import Data.DataType hiding (list) 7 | import Test 8 | 9 | import Test.Hspec 10 | import Test.QuickCheck hiding (Args) 11 | import Control.Exception(evaluate) 12 | 13 | -- extractValue (Right a) = a 14 | 15 | testRead = extractValue . transform . parseExpr 16 | 17 | test a b = testRead a `shouldBe` b 18 | 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "transform an Expr to LispVal" $ do 23 | context "number" $ do 24 | it "transform a number" $ do 25 | test "123" (integer 123) 26 | test "12.3" (double 12.3) 27 | context "list" $ do 28 | it "transform a list" $ do 29 | test "{1}" (list [integer 1]) 30 | test "{1,2}" (list [integer 1, integer 2]) 31 | context "plus" $ do 32 | it "flatten plus" $ do 33 | test "1+2" (plus [one, two]) 34 | test "1+2+3" (plus [one,two,three]) 35 | test "P+2+3+1" (plus [pe, two, three,one]) 36 | it "minus" $ do 37 | test "1-2" (plus [one, integer (-2)]) 38 | test "1+2-3" (plus [one, two, integer (-3)]) 39 | test "1+2-P" (plus [one, two, negateE pe]) 40 | 41 | context "times" $ do 42 | it "times" $ do 43 | test "1 2" (times [one, two]) 44 | test "1 P 3" (times [one, pe, three]) 45 | test "2 * 3" (times [two, three]) 46 | it "divide" $ do 47 | test "1 /2" (times [one, inverseE two]) 48 | test "1 2/3" (times [one, two, inverseE three]) 49 | test "1/P *2" (times [one,inverseE pe, two]) 50 | context "logical expression" $ do 51 | it "and logic" $ do 52 | test "1&&2" (andE [one, two]) 53 | test "P&&1" (andE [pe, one]) 54 | test "P&&1&&2" (andE [pe, one,two]) 55 | it "or" $ do 56 | test "1||2||3" (orE [one,two,three]) 57 | test "1&&P||2" (orE [andE [one,pe], two]) 58 | it "not" $ do 59 | test "!P&&P" (andE [notE [pe], pe]) 60 | 61 | context "compound expression" $ do 62 | it "compound" $ do 63 | test "1;2;3" (comp [one,two,three]) 64 | -- test "1;2;P;" (comp [one,two,pe,atomNull]) 65 | 66 | context "Inequality" $ do 67 | it "test equal" $ do 68 | test "1==2" (ineq [one,equal,two]) 69 | test "1==2==3" (ineq [one, equal,two,equal,three]) 70 | it "comb" $ do 71 | test "1==2>=3" (ineq [one,equal,two,greatEq,three]) 72 | test "1<=2+P!=3" (ineq [one, lessEq,plus [two,pe],unEq ,three]) 73 | test "1<2>3" (ineq [one,less,two,great,three]) 74 | test "1<=1+2!=3" (ineq [one,lessEq,plus [one,two],unEq,three]) 75 | 76 | context "function apply" $ do 77 | it "nest apply" $ do 78 | test "P[P[1]]" $ List [pe,List [pe, one]] 79 | test "P[1,2]" $ List [pe, one,two] 80 | it "curry" $ do 81 | test "P[1][2]" $ List [List [pe,one], two] 82 | it "operator form" $ do 83 | test "P@1@2//3" $ List [three,List [pe,List [one,two]]] 84 | test "P@1+2//3" $ List [three,plus [List [pe,one],two]] 85 | 86 | context "part" $ do 87 | it "part expression" $ do 88 | test "P[[1,2]]" $ part [pe,one,two] 89 | test "P[1][[2]]" $ part [List [pe,one],two] 90 | test "P[2[[1]]]" $ List [pe, part [two, one]] 91 | context "Atom" $ do 92 | it "atom name" $ do 93 | test "P" pe 94 | 95 | context "Factorial" $ do 96 | it "factorial !" $ do 97 | test "2!" (fact two) 98 | test "1+2!" (plus [one,fact two]) 99 | test "2! != 3!" (ineq [fact two,unEq,fact three]) 100 | test "2!! != P!" (ineq [fact2 two,unEq,fact pe]) 101 | 102 | context "Map,MapAll,Apply,Apply1" $ do 103 | it "Map" $ do 104 | test "P/@{1,2}" (map' [pe,list [one,two]]) 105 | test "P/@P/@1" (map' [pe,map' [pe,one]]) 106 | test "P/@1@2" (map' [pe, List [one,two]]) 107 | 108 | it "MapAll" $ do 109 | test "P//@1" (mapAll [pe,one]) 110 | test "P//@1/@2" (mapAll [pe,map' [one,two]]) 111 | 112 | it "apply" $ do 113 | test "P@@1/@2@3" (apply [pe,map' [one,List [two,three]]]) 114 | test "P@@@2@@1" (apply1 [pe,apply [two,one]]) 115 | 116 | context "derivative" $ do 117 | it "nth derivative" $ do 118 | test "P'" (deriv 1 pe) 119 | test "P''''" (deriv 4 pe) 120 | it "apply to args" $ do 121 | test "P''[1]" (List [deriv 2 pe,one]) 122 | test "P'[1][2]" (List [List [deriv 1 pe,one],two]) 123 | 124 | context "replace rule" $ do 125 | it "replace rule operators" $ do 126 | test "P/.1 -> 2" (replace [pe,rule [one,two]]) 127 | test "P /. (1 //. 2 -> 3) -> P" (replace [pe,rule [replaceR [one,rule [two,three]],pe]]) 128 | test "P//.2:>3" (replaceR [pe,ruleD [two,three]]) 129 | it "condition replace" $ do 130 | test "1/.P_ -> 2/;P>=1" (replace [one,rule [patt [pe,blk],cond [two,ineq [pe,greatEq,one]]]]) 131 | it "alternative replace" $ do 132 | test "1/.1|2 -> 3" (replace [one,rule [alter [one,two],three]]) 133 | 134 | context "Set SetDelayed" $ do 135 | it "set" $ do 136 | test "P=1" (set [pe,one]) 137 | test "P:=1=2" (setD [pe,set [one,two]]) 138 | test "P=1+2" (set [pe,plus [one,two]]) 139 | 140 | context "Unset" $ do 141 | it "unset a var" $ do 142 | test "P=." (unset pe) 143 | 144 | context "Dot" $ do 145 | it "Dot" $ do 146 | test "P.{1,2}" (dot [pe,list [one,two]]) 147 | test "{1,2}.{2,3}" (dot [list [one,two],list [two,three]]) 148 | 149 | context "Pattern special form" $ do 150 | it "special form" $ do 151 | test "P_" (patt [pe, blk]) 152 | test "P_?(1+2)" (pattT [patt [pe,blk], plus [one,two]]) 153 | 154 | context "lambda function" $ do 155 | it "& operator" $ do 156 | test "(1+#)&" (fun [plus [one,s1]]) 157 | test "(1+#&)[2]" (List [fun [plus [one,s1]],two]) 158 | test "(1 ##&)[2]" (List [fun [times [one,ss1]],two]) 159 | 160 | context "alternative" $ do 161 | it "| operator" $ do 162 | test "1|2|3" (alter [one,two,three]) 163 | 164 | main = hspec spec 165 | -------------------------------------------------------------------------------- /mmaclone/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------