├── .github └── workflows │ └── build-test-push.yaml ├── .gitignore ├── Dockerfile ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── app └── Main.hs ├── demo.gif ├── repl.expect ├── silly-joy.cabal ├── src ├── Meaning.hs ├── Parser.hs ├── Runner.hs └── UI.hs ├── stack.yaml └── test └── Main.hs /.github/workflows/build-test-push.yaml: -------------------------------------------------------------------------------- 1 | name: Build, test and push image 2 | on: 3 | push: 4 | workflow_dispatch: 5 | 6 | jobs: 7 | build-test-push: 8 | runs-on: ubuntu-latest 9 | steps: 10 | - name: Set up Docker Buildx 11 | uses: docker/setup-buildx-action@v3 12 | 13 | - name: Expose GitHub Runtime 14 | uses: crazy-max/ghaction-github-runtime@v3 15 | 16 | - name: Check out repository code 17 | uses: actions/checkout@v4 18 | with: 19 | fetch-depth: 0 20 | 21 | - name: Build image and run tests 22 | run: | 23 | docker buildx build \ 24 | --output=type=docker \ 25 | --cache-to type=gha,mode=max \ 26 | --cache-from type=gha \ 27 | --load \ 28 | --progress=plain \ 29 | --iidfile=iid \ 30 | . 31 | 32 | - name: Login to Docker Hub 33 | uses: docker/login-action@v3 34 | with: 35 | username: ${{ vars.DOCKERHUB_USERNAME }} 36 | password: ${{ secrets.DOCKERHUB_TOKEN }} 37 | 38 | - name: Tag and push image 39 | run: | 40 | docker tag $( 1 2 + 32 | > :stack 33 | 3 34 | > 12 * 35 | > print 36 | 36 37 | > fact := [[pop 0 =] [pop pop 1] [ [dup 1 -] dip dup i *] ifte] dup i 38 | > 10 fact 39 | > :st 40 | 3628800 41 | > ["foo" "bar" strcat] [strlen] b 42 | > dup print 43 | 6 44 | > 1 swap - print 45 | -5 46 | > even := 2 % 0 = 47 | > odd := even not 48 | > 3 odd 2 even and print 49 | true 50 | > prime := [dup even [3 <] dip or] [2 =] [prime_trial_division] ifte 51 | > prime_trial_division := 3 [[pop % null] [pop =] [[2 +] dip x] ifte] x 52 | > [2 3 4 5 6 7 8 9 10 11 12 13] [prime] map print 53 | [true true false true false true false false false true false true] 54 | > sum := 0 [+] fold 55 | > div-3-5 := [dup [3 % null] dip 5 % null or] filter 56 | > up-to := pred [[]] [cons] primrec 57 | > 10 up-to div-3-5 sum print 58 | 23 59 | > next-fib := dup [+] dip swap 60 | > add-if-even := [even] [dup [rotate] dip + rotate] [] ifte 61 | > 0 1 1 [100 >] [pop pop] [next-fib add-if-even] [i] genrec print 62 | 188 63 | ``` 64 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | module Main where 3 | 4 | import UI (runRepl, runTui) 5 | 6 | import Options.Applicative 7 | import Data.Semigroup ((<>)) 8 | 9 | data Config = MkConfig { tui :: Bool } 10 | 11 | config :: Parser Config 12 | config = do 13 | s <- switch ( long "tui" <> short 't' <> help "Run with terminal UI") 14 | return $ MkConfig s 15 | 16 | parser :: ParserInfo Config 17 | parser = 18 | info (config <**> helper) 19 | (fullDesc <> header "silly-joy - a silly intepreter for joy") 20 | 21 | main :: IO () 22 | main = do 23 | c <- execParser parser 24 | case tui c of 25 | True -> runTui 26 | False -> runRepl 27 | -------------------------------------------------------------------------------- /demo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rootmos/silly-joy/fd3867fbf82342bdb571ed7bed9f86099bf202a2/demo.gif -------------------------------------------------------------------------------- /repl.expect: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env expect 2 | spawn [lindex $argv 0] 3 | 4 | set timeout 5 5 | 6 | set prompt {> } 7 | 8 | expect -re $prompt 9 | send "1 2 +\r" 10 | 11 | expect -re $prompt 12 | send ":stack\r" 13 | expect { 14 | "3" {} 15 | timeout { exit 1 } 16 | } 17 | 18 | expect -re $prompt 19 | send "12 *\r" 20 | 21 | expect -re $prompt 22 | send "print\r" 23 | expect { 24 | "36" {} 25 | timeout { exit 1 } 26 | } 27 | 28 | expect -re $prompt 29 | send "fact := \[\[pop 0 =\] \[pop pop 1\] \[ \[dup 1 -\] dip dup i *\] ifte\] dup i\r" 30 | 31 | expect -re $prompt 32 | send "10 fact\r" 33 | 34 | expect -re $prompt 35 | send ":st\r" 36 | expect { 37 | "3628800" {} 38 | timeout { exit 1 } 39 | } 40 | 41 | expect -re $prompt 42 | send "\[\"foo\" \"bar\" strcat\] \[strlen\] b\r" 43 | 44 | expect -re $prompt 45 | send "dup print\r" 46 | expect { 47 | "6" {} 48 | timeout { exit 1 } 49 | } 50 | 51 | expect -re $prompt 52 | send "1 swap - print\r" 53 | expect { 54 | -exact "-5" {} 55 | timeout { exit 1 } 56 | } 57 | 58 | expect -re $prompt 59 | send "even := 2 % 0 =\r" 60 | 61 | expect -re $prompt 62 | send "odd := even not\r" 63 | 64 | expect -re $prompt 65 | send "3 odd 2 even and print\r" 66 | expect { 67 | "true" {} 68 | timeout { exit 1 } 69 | } 70 | 71 | expect -re $prompt 72 | send "prime := \[dup even \[3 <\] dip or\] \[2 =\] \[prime_trial_division\] ifte\r" 73 | expect -re $prompt 74 | send "prime_trial_division := 3 \[\[pop % null\] \[pop =\] \[\[2 +\] dip x\] ifte\] x\r" 75 | 76 | expect -re $prompt 77 | send "\[2 3 4 5 6 7 8 9 10 11 12 13\] \[prime\] map print\r" 78 | expect { 79 | "\\\[true true false true false true false false false true false true\\\]" {} 80 | timeout { exit 1 } 81 | } 82 | 83 | expect -re $prompt 84 | send "sum := 0 \[+\] fold\r" 85 | expect -re $prompt 86 | send "div-3-5 := \[dup \[3 % null\] dip 5 % null or\] filter\r" 87 | expect -re $prompt 88 | send "up-to := pred \[\[\]\] \[cons\] primrec\r" 89 | expect -re $prompt 90 | send "10 up-to div-3-5 sum print\r" 91 | expect { 92 | "23" {} 93 | timeout { exit 1 } 94 | } 95 | 96 | 97 | expect -re $prompt 98 | send "next-fib := dup \[+\] dip swap\r" 99 | expect -re $prompt 100 | send "add-if-even := \[even\] \[dup \[rotate\] dip + rotate\] \[\] ifte\r" 101 | expect -re $prompt 102 | send "0 1 1 \[100 >\] \[pop pop\] \[next-fib add-if-even\] \[i\] genrec print\r" 103 | expect { 104 | "188" {} 105 | timeout { exit 1 } 106 | } 107 | -------------------------------------------------------------------------------- /silly-joy.cabal: -------------------------------------------------------------------------------- 1 | name: silly-joy 2 | version: 0.0.1 3 | homepage: https://github.com/rootmos/silly-joy#readme 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Gustav Behm 7 | maintainer: gustav.behm@gmail.com 8 | copyright: 2017 Gustav Behm 9 | category: language 10 | build-type: Simple 11 | extra-source-files: README.md 12 | cabal-version: >=1.10 13 | 14 | library 15 | hs-source-dirs: src 16 | exposed-modules: Parser, Meaning, Runner, UI 17 | build-depends: base >= 4.7 && < 5 18 | , parsec >= 3.1.11 19 | , containers >= 0.5.7.1 20 | , extensible-effects >= 1.11.1.0 21 | , natural-transformation >= 0.4 22 | , brick >= 0.17.2 23 | , haskeline 24 | , vty >= 5.15.1 25 | , directory >= 1.3.0.0 26 | , mtl >= 2.2.1 27 | ghc-options: -Wall 28 | default-language: Haskell2010 29 | 30 | executable silly-joy-exe 31 | hs-source-dirs: app 32 | main-is: Main.hs 33 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 34 | build-depends: base 35 | , silly-joy 36 | , optparse-applicative >= 0.13.2.0 37 | ghc-options: -optl-static -fPIC 38 | default-language: Haskell2010 39 | 40 | test-suite silly-joy-test 41 | type: exitcode-stdio-1.0 42 | hs-source-dirs: test 43 | main-is: Main.hs 44 | build-depends: base 45 | , silly-joy 46 | , hspec >= 2.4.3 47 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 48 | default-language: Haskell2010 49 | 50 | source-repository head 51 | type: git 52 | location: https://github.com/rootmos/silly-joy 53 | -------------------------------------------------------------------------------- /src/Meaning.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, DeriveFunctor, TypeOperators, TypeFamilies #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Meaning ( Program (unProgram) 4 | , StateEffect (..) 5 | , RealWorldEffect (..) 6 | , Error (..) 7 | , Value (..) 8 | , primitives 9 | , meaning 10 | ) where 11 | 12 | import qualified Data.Map.Lazy as M 13 | import Control.Eff hiding ( send, run ) 14 | import qualified Control.Eff as E 15 | import Control.Eff.Exception 16 | import Control.Exception ( Exception ) 17 | import Data.Void 18 | import Prelude hiding ( lookup, print ) 19 | import Text.Read (readMaybe) 20 | import Data.Monoid 21 | import Data.List (intercalate) 22 | 23 | import Parser 24 | 25 | data Program = MkProgram { unProgram :: Eff (StateEffect 26 | :> (Exc Error) 27 | :> RealWorldEffect :> Void) () 28 | , ast :: AST 29 | } 30 | 31 | instance Monoid Program where 32 | mempty = MkProgram { unProgram = return (), ast = [] } 33 | p `mappend` q = MkProgram { unProgram = unProgram p >> unProgram q 34 | , ast = ast p ++ ast q 35 | } 36 | 37 | instance Eq Program where 38 | p == p' = ast p == ast p' 39 | 40 | instance Show Program where 41 | show = prettyAST . ast 42 | 43 | 44 | -- Value 45 | 46 | data Value = A [Value] | P Program | I Integer | B Bool | S String 47 | deriving ( Eq ) 48 | 49 | instance Show Value where 50 | show (I i) = show i 51 | show (B True) = "true" 52 | show (B False) = "false" 53 | show (A xs) = "[" ++ (intercalate " " $ map show xs) ++ "]" 54 | show (P p) = show p 55 | show (S s) = "\"" ++ s ++ "\"" 56 | 57 | data Error = Undefined Name 58 | | PoppingEmptyStack 59 | | PeekingEmptyStack 60 | | PoppingEmptyStateStack 61 | | TypeMismatch Value String 62 | | UnparseableAsNumber String 63 | | EmptyAggregate 64 | deriving ( Show, Eq ) 65 | 66 | instance Exception Error 67 | 68 | 69 | -- The StateEffect 70 | 71 | data StateEffect v = Push Value v 72 | | Pop (Value -> v) 73 | | Peek (Value -> v) 74 | | Lookup Name (Program -> v) 75 | | ClearStack v 76 | | PushState v 77 | | PopState v 78 | | Bind Name Program v 79 | deriving ( Functor ) 80 | 81 | lookup :: Member StateEffect e => Name -> Eff e Program 82 | lookup n = E.send . inj $ Lookup n id 83 | 84 | push :: Member StateEffect e => Value -> Eff e () 85 | push v = E.send . inj $ Push v () 86 | 87 | pop :: Member StateEffect e => Eff e Value 88 | pop = E.send . inj $ Pop id 89 | 90 | peek :: Member StateEffect e => Eff e Value 91 | peek = E.send . inj $ Peek id 92 | 93 | local :: Member StateEffect e => Eff e a -> Eff e a 94 | local p = do 95 | () <- E.send . inj $ PushState () 96 | a <- p 97 | () <- E.send . inj $ PopState () 98 | return a 99 | 100 | bind :: Member StateEffect e => Name -> Program -> Eff e () 101 | bind n p = E.send . inj $ Bind n p () 102 | 103 | clear :: Member StateEffect e => Eff e () 104 | clear = E.send . inj $ ClearStack () 105 | 106 | -- RealWorldEffect 107 | 108 | data RealWorldEffect v = Print String v 109 | | Input (String -> v) 110 | deriving ( Functor ) 111 | 112 | 113 | print :: Member RealWorldEffect e => String -> Eff e () 114 | print s = E.send . inj $ Print s () 115 | 116 | input :: Member RealWorldEffect e => Eff e String 117 | input = E.send . inj $ Input id 118 | 119 | 120 | -- The primitives 121 | 122 | primitives :: M.Map Name Program 123 | primitives = M.fromList 124 | [ mk "pop" $ pop >> return () 125 | , mk "clear" $ clear 126 | , mk "i" $ pop >>= castProgram >>= unProgram 127 | , mk "x" $ peek >>= castProgram >>= unProgram 128 | , mk "dup" $ peek >>= push 129 | , mk "dip" $ do 130 | p <- pop 131 | v <- pop 132 | castProgram p >>= unProgram 133 | push v 134 | , mk "+" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (I $ b + a) 135 | , mk "-" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (I $ b - a) 136 | , mk "*" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (I $ b * a) 137 | , mk "<" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (B $ b < a) 138 | , mk ">" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (B $ b > a) 139 | , mk "<=" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (B $ b <= a) 140 | , mk ">=" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (B $ b >= a) 141 | , mk "=" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (B $ b == a) 142 | , mk "!=" $ do a <- pop >>= castInt; b <- pop >>= castInt; push (B $ b /= a) 143 | , mk "true" $ push (B True) 144 | , mk "false" $ push (B False) 145 | , mk "and" $ do 146 | a <- pop >>= castBool 147 | b <- pop >>= castBool 148 | push (B $ a && b) 149 | , mk "or" $ do 150 | a <- pop >>= castBool 151 | b <- pop >>= castBool 152 | push (B $ a || b) 153 | , mk "not" $ do 154 | a <- pop >>= castBool 155 | push (B $ not a) 156 | , mk "null" $ do 157 | v <- pop 158 | case v of 159 | I 0 -> push $ B True 160 | I _ -> push $ B False 161 | A [] -> push $ B True 162 | A _ -> push $ B False 163 | _ -> throwExc $ TypeMismatch v "expecting number or aggregate" 164 | , mk "small" $ do 165 | v <- pop 166 | case v of 167 | I 0 -> push $ B True 168 | I 1 -> push $ B True 169 | I _ -> push $ B False 170 | A [] -> push $ B True 171 | A (_:[]) -> push $ B True 172 | A _ -> push $ B False 173 | _ -> throwExc $ TypeMismatch v "expecting number or aggregate" 174 | , mk "succ" $ do a <- pop >>= castInt; push (I $ succ a) 175 | , mk "pred" $ do a <- pop >>= castInt; push (I $ pred a) 176 | , mk "/" $ do 177 | a <- pop >>= castInt 178 | b <- pop >>= castInt 179 | push (I $ b `div` a) 180 | , mk "%" $ do 181 | a <- pop >>= castInt 182 | b <- pop >>= castInt 183 | push (I $ b `mod` a) 184 | , mk "div" $ do 185 | a <- pop >>= castInt 186 | b <- pop >>= castInt 187 | let (q, r) = divMod b a 188 | push (I q) 189 | push (I r) 190 | , mk "print" $ pop >>= print . show 191 | , mk "ifte" $ do 192 | false <- pop 193 | true <- pop 194 | cond <- pop 195 | 196 | c <- local (castProgram cond >>= unProgram >> peek >>= castBool) 197 | case c of 198 | True -> castProgram true >>= unProgram 199 | False -> castProgram false >>= unProgram 200 | , mk "I" $ do 201 | p <- pop >>= castProgram 202 | v <- local (unProgram p >> peek) 203 | push v 204 | , mk "swap" $ do a <- pop; b <- pop; push a; push b 205 | , mk "concat" $ do 206 | a <- pop >>= castAggregate 207 | b <- pop >>= castAggregate 208 | push $ A (b <> a) 209 | , mk "b" $ do 210 | a <- pop >>= castProgram 211 | b <- pop >>= castProgram 212 | (unProgram b) >> (unProgram a) 213 | , mk "size" $ do 214 | a <- pop >>= castAggregate 215 | push $ I (toInteger $ length a) 216 | , mk "cons" $ do 217 | a <- pop >>= castAggregate 218 | b <- pop 219 | push $ A (b : a) 220 | , mk "first" $ do 221 | ag <- pop >>= castAggregate 222 | case ag of 223 | (P p):_ -> unProgram p 224 | v:_ -> push v 225 | [] -> throwExc EmptyAggregate 226 | , mk "rest" $ do 227 | ag <- pop >>= castAggregate 228 | case ag of 229 | _:tl -> push $ A tl 230 | [] -> throwExc EmptyAggregate 231 | , mk "uncons" $ do 232 | ag <- pop >>= castAggregate 233 | case ag of 234 | (P p):tl -> do 235 | unProgram p 236 | push $ A tl 237 | v:tl -> do 238 | push v 239 | push $ A tl 240 | [] -> throwExc EmptyAggregate 241 | , mk "strlen" $ do 242 | s <- pop >>= castStr 243 | push $ I (toInteger $ length s) 244 | , mk "strcat" $ do 245 | s <- pop >>= castStr 246 | s' <- pop >>= castStr 247 | push $ S (s' ++ s) 248 | , mk "bind" $ do 249 | n <- pop >>= castStr 250 | p <- pop >>= castProgram 251 | bind n p 252 | , mk "read_line" $ do 253 | s <- input 254 | push $ S s 255 | , mk "read_int" $ do 256 | s <- input 257 | case readMaybe s of 258 | Just i -> push $ I i 259 | Nothing -> throwExc $ UnparseableAsNumber s 260 | , mk "rolldown" $ do 261 | z <- pop 262 | y <- pop 263 | x <- pop 264 | push y 265 | push z 266 | push x 267 | , mk "rollup" $ do 268 | z <- pop 269 | y <- pop 270 | x <- pop 271 | push z 272 | push x 273 | push y 274 | , mk "rotate" $ do 275 | z <- pop 276 | y <- pop 277 | x <- pop 278 | push z 279 | push y 280 | push x 281 | , mk "primrec" $ do 282 | c <- pop >>= castProgram 283 | i <- pop >>= castProgram 284 | let loop = do 285 | x <- peek >>= castInt 286 | case x of 287 | 0 -> pop >> unProgram i 288 | n -> push (I $ n - 1) >> loop >> unProgram c 289 | loop 290 | , mk "linrec" $ do 291 | r2 <- pop >>= castProgram 292 | r1 <- pop >>= castProgram 293 | t <- pop >>= castProgram 294 | p <- pop >>= castProgram 295 | let loop = do 296 | b <- local (unProgram p >> peek >>= castBool) 297 | if b then unProgram t 298 | else unProgram r1 >> loop >> unProgram r2 299 | loop 300 | , mk "genrec" $ do 301 | let loop = do 302 | r2 <- pop 303 | r1 <- pop 304 | t <- pop 305 | b <- pop 306 | b' <- local (castProgram b >>= unProgram >> peek >>= castBool) 307 | if b' then castProgram t >>= unProgram 308 | else do 309 | castProgram r1 >>= unProgram 310 | push $ A [b, t, r1, r2, P $ MkProgram loop []] 311 | castProgram r2 >>= unProgram 312 | loop 313 | , mk "times" $ do 314 | n <- pop >>= castInt 315 | p <- pop >>= castProgram 316 | sequence_ $ replicate (fromInteger n) $ unProgram p 317 | , mk "map" $ do 318 | p <- pop >>= castProgram 319 | as <- pop >>= castAggregate 320 | as' <- sequence $ flip fmap as $ 321 | \case { P q -> local $ unProgram q >> unProgram p >> peek; 322 | v -> local $ push v >> unProgram p >> peek 323 | } 324 | push $ A as' 325 | , mk "filter" $ do 326 | p <- pop >>= castProgram 327 | as <- pop >>= castAggregate 328 | as' <- sequence $ flip fmap as $ \v -> local $ do 329 | case v of 330 | P q -> unProgram q 331 | _ -> push v 332 | unProgram p 333 | b <- peek >>= castBool 334 | return $ if b then [v] else [] 335 | push $ A $ concat as' 336 | , mk "fold" $ do 337 | f <- pop >>= castProgram 338 | z <- pop 339 | as <- pop >>= castAggregate 340 | let go = \case { [] -> return (); 341 | (P p:tl) -> unProgram p >> unProgram f >> go tl; 342 | (v:tl) -> push v >> unProgram f >> go tl 343 | } 344 | push z 345 | go as 346 | , mk "app2" $ do 347 | f <- pop >>= castProgram 348 | b <- pop 349 | a <- pop 350 | b' <- local (push b >> unProgram f >> peek) 351 | a' <- local (push a >> unProgram f >> peek) 352 | push a' 353 | push b' 354 | ] 355 | where 356 | mk n p = (n, MkProgram { unProgram = p, ast = [Word n] }) 357 | 358 | castProgram :: Member (Exc Error) e => Value -> Eff e Program 359 | castProgram (P p) = return p 360 | castProgram (A xs) = 361 | sequence (map weakCastProgram xs) >>= return . mconcat 362 | where 363 | weakCastProgram :: Member (Exc Error) e 364 | => Value -> Eff e Program 365 | weakCastProgram (I n) = return $ 366 | MkProgram { unProgram = push (I n) 367 | , ast = [Number n] 368 | } 369 | weakCastProgram (S s) = return $ 370 | MkProgram { unProgram = push (S s) 371 | , ast = [Str s] 372 | } 373 | weakCastProgram (A xs) = return $ 374 | MkProgram { unProgram = push $ A xs 375 | , ast = [] -- TODO: Are any casted programs shown to the user? 376 | } 377 | weakCastProgram v = castProgram v 378 | castProgram v = throwExc $ TypeMismatch v "expecting program" 379 | 380 | castAggregate :: Member (Exc Error) e => Value -> Eff e [Value] 381 | castAggregate (A xs) = return xs 382 | castAggregate v = throwExc $ TypeMismatch v "expecting aggregate" 383 | 384 | castInt :: Member (Exc Error) e => Value -> Eff e Integer 385 | castInt (I i) = return i 386 | castInt v = throwExc $ TypeMismatch v "expecting number" 387 | 388 | castBool :: Member (Exc Error) e => Value -> Eff e Bool 389 | castBool (B b) = return b 390 | castBool v = throwExc $ TypeMismatch v "expecting boolean" 391 | 392 | castStr :: Member (Exc Error) e => Value -> Eff e String 393 | castStr (S s) = return s 394 | castStr v = throwExc $ TypeMismatch v "expecting string" 395 | 396 | -- Meaning function 397 | -- - AST is just [Term]: the syntactic monoid 398 | -- - Program also a monoid, and can be seen as the semantic monoid 399 | 400 | meaning :: AST -> Program 401 | meaning [] = mempty 402 | meaning (a@(Word n):ts) = 403 | let p = MkProgram { unProgram = lookup n >>= unProgram 404 | , ast = [a] 405 | } in 406 | p <> meaning ts 407 | meaning (a@(Quoted as):ts) = 408 | let p = MkProgram { unProgram = do 409 | push (A $ map (\t -> P . meaning $ [t]) as) 410 | , ast = [a] 411 | } in 412 | p <> meaning ts 413 | meaning (a@(Number n):ts) = 414 | let p = MkProgram { unProgram = push (I n), ast = [a] } in 415 | p <> meaning ts 416 | meaning (a@(Str s):ts) = 417 | let p = MkProgram { unProgram = push (S s), ast = [a] } in 418 | p <> meaning ts 419 | meaning (a@(Binding n b):ts) = 420 | let p = MkProgram { unProgram = do 421 | push $ P (meaning b) 422 | push $ S n 423 | lookup "bind" >>= unProgram 424 | , ast = [a] } in 425 | p <> meaning ts 426 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser ( parse 2 | , Term (..) 3 | , Name 4 | , AST 5 | , prettyAST 6 | ) where 7 | 8 | import Text.Parsec ( many1 9 | , alphaNum 10 | , Parsec 11 | , (<|>) 12 | , between 13 | , spaces 14 | , space 15 | , optional 16 | , sepEndBy 17 | , many 18 | , eof 19 | , oneOf 20 | , try 21 | ) 22 | import qualified Text.Parsec as P 23 | import Text.Parsec.Char (char, letter, digit) 24 | import Data.List (intercalate) 25 | import Data.Bifunctor (first) 26 | 27 | data Term = Word Name 28 | | Quoted AST 29 | | Number Integer 30 | | Str String 31 | | Binding Name AST 32 | deriving (Eq, Show) 33 | type Name = String 34 | type AST = [Term] 35 | 36 | prettyAST :: AST -> String 37 | prettyAST = intercalate " " . map prettyTerm 38 | where 39 | prettyTerm (Word n) = n 40 | prettyTerm (Number n) = show n 41 | prettyTerm (Quoted a) = "[" ++ prettyAST a ++ "]" 42 | prettyTerm (Str s) = "\"" ++ s ++ "\"" 43 | prettyTerm (Binding n a) = n ++ " := " ++ prettyAST a ++ ";" 44 | 45 | parse :: String -> Either String AST 46 | parse = first show . P.parse (ast <* eof) "parsing silly-joy" 47 | 48 | ast :: Parsec String st AST 49 | ast = spaces >> (try binding <|> term) `sepEndBy` separator 50 | where 51 | separator = optional spaces >> optional (char ';') >> spaces 52 | 53 | binding :: Parsec String st Term 54 | binding = do 55 | n <- name 56 | _ <- spaces 57 | _ <- char ':' 58 | _ <- char '=' 59 | _ <- spaces 60 | a <- term `sepEndBy` spaces 61 | return $ Binding n a 62 | where 63 | name = many1 $ alphaNum <|> oneOf symbols 64 | 65 | symbols :: [Char] 66 | symbols = ['+', '=', '<', '>', '!', '-', '*', '_', '/', '%'] 67 | 68 | term :: Parsec String st Term 69 | term = number <|> word <|> quoted <|> str 70 | 71 | str :: Parsec String st Term 72 | str = Str <$> between (char '"') (char '"') (many quoted_char) 73 | where 74 | quoted_char = space 75 | <|> alphaNum 76 | <|> oneOf symbols 77 | <|> (try (char '\\') >> char '"') 78 | 79 | word :: Parsec String st Term 80 | word = do 81 | l <- letter <|> symbol 82 | ans <- many (alphaNum <|> symbol) 83 | return . Word $ l : ans 84 | where symbol = oneOf symbols 85 | 86 | number :: Parsec String st Term 87 | number = positive <|> try negative 88 | where 89 | positive = Number . read <$> many1 digit 90 | negative = do 91 | _ <- char '-' 92 | n <- many1 digit 93 | return . Number $ -1 * read n 94 | 95 | quoted :: Parsec String st Term 96 | quoted = Quoted <$> between (char '[') (char ']') ast 97 | -------------------------------------------------------------------------------- /src/Runner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, TypeOperators, TypeFamilies, Rank2Types #-} 2 | module Runner ( State (..) 3 | , simulateUnsafe 4 | , expect 5 | , send 6 | , runIO 7 | , runInputT 8 | , initialState 9 | ) where 10 | 11 | import qualified Data.Map.Lazy as M 12 | import Control.Eff hiding ( send ) 13 | import qualified Control.Eff as E 14 | import Control.Eff.Exception 15 | import Control.Eff.Lift 16 | import Control.Exception ( Exception, throw ) 17 | import Control.Monad.IO.Class (liftIO, MonadIO) 18 | import Prelude hiding ( lookup, print ) 19 | import Data.Typeable 20 | import Data.List (intercalate) 21 | import Data.OpenUnion (weaken) 22 | import Control.Natural 23 | 24 | import Parser 25 | import Meaning 26 | 27 | import System.Console.Haskeline (InputT, outputStrLn, getInputLine, MonadException) 28 | 29 | initialState :: State 30 | initialState = State { stack = [] 31 | , dict = primitives 32 | , prevState = Nothing 33 | } 34 | 35 | data State = State { stack :: [Value] 36 | , dict :: M.Map Name Program 37 | , prevState :: Maybe State 38 | } 39 | 40 | instance Show State where 41 | show (State { stack = s, prevState = ps }) = 42 | "stack=" ++ intercalate "," (map show s) ++ prettyPrevState ps 43 | where 44 | prettyPrevState (Just st) = " prevState={" ++ show st ++ "}" 45 | prettyPrevState Nothing = " prevState={}" 46 | 47 | 48 | 49 | runStateEffect :: Member (Exc Error) e => State -> Eff (StateEffect :> e) v 50 | -> Eff e (State, v) 51 | runStateEffect st = freeMap (\x -> return (st, x)) 52 | (\u -> handleRelay u (runStateEffect st) (handle st)) 53 | where 54 | handle s (Push v k) = 55 | let s' = s { stack = v : stack s } in runStateEffect s' k 56 | 57 | handle (s@State { stack = v : stk }) (Pop k) = 58 | runStateEffect (s { stack = stk }) (k v) 59 | handle (State { stack = [] }) (Pop _) = 60 | throwExc PoppingEmptyStack 61 | 62 | handle (s@State { stack = v : _ }) (Peek k) = 63 | runStateEffect s (k v) 64 | handle (State { stack = [] }) (Peek _) = 65 | throwExc PeekingEmptyStack 66 | 67 | handle (s@State { dict = d }) (Lookup n k) = 68 | case M.lookup n d of 69 | Just p -> runStateEffect s (k p) 70 | Nothing -> throwExc $ Undefined n 71 | 72 | handle s (PushState k) = do 73 | let s' = s { prevState = Just s } 74 | runStateEffect s' k 75 | 76 | handle (State { prevState = Just s }) (PopState k) = 77 | runStateEffect s k 78 | 79 | handle (State { prevState = Nothing }) (PopState _) = 80 | throwExc PoppingEmptyStateStack 81 | 82 | handle (s@State { dict = d }) (Bind n p k) = do 83 | let s' = s { dict = M.insert n p d } 84 | runStateEffect s' k 85 | 86 | handle s (ClearStack k) = do 87 | let s' = s { stack = [] } 88 | runStateEffect s' k 89 | 90 | 91 | data SimulatedIO = ExpectOutput String | SendInput String 92 | 93 | send :: String -> SimulatedIO 94 | send = SendInput 95 | 96 | expect :: String -> SimulatedIO 97 | expect = ExpectOutput 98 | 99 | data SimulatedIOError = UnexpectedOutput String 100 | | IncorrectOutput String String 101 | | UnexpectedInput 102 | | EndOfExpectations 103 | deriving ( Show ) 104 | 105 | instance Exception SimulatedIOError 106 | 107 | simulateRealWorld :: [SimulatedIO] -> Eff (RealWorldEffect :> e) ~> Eff e 108 | simulateRealWorld expects = freeMap return 109 | (\u -> handleRelay u (simulateRealWorld expects) (handle expects)) 110 | where 111 | handle [] _ = throw EndOfExpectations 112 | handle (ExpectOutput o : exs) (Print o' k) 113 | | o == o' = simulateRealWorld exs k 114 | | otherwise = throw $ IncorrectOutput o o' 115 | 116 | handle (SendInput i : exs) (Input k) = 117 | simulateRealWorld exs (k i) 118 | 119 | handle (SendInput _ : _) (Print o _) = 120 | throw $ UnexpectedOutput o 121 | 122 | handle (ExpectOutput _ : _) (Input _) = 123 | throw $ UnexpectedInput 124 | 125 | simulateUnsafe :: String -> [SimulatedIO] -> State 126 | simulateUnsafe s exs = 127 | let parsed = either error id $ parse s in 128 | let p = meaning parsed in 129 | let (st, ()) = either throw id . run . 130 | simulateRealWorld exs . runExc . 131 | runStateEffect initialState . unProgram $ p in 132 | st 133 | 134 | runRealWorldIO :: Eff (RealWorldEffect :> e) ~> Eff (Lift IO :> e) 135 | runRealWorldIO = freeMap return $ \u -> 136 | transform u runRealWorldIO handle 137 | where 138 | handle :: RealWorldEffect (Eff (RealWorldEffect :> e) w) 139 | -> Eff (Lift IO :> e) w 140 | handle (Print s k) = lift (putStrLn s) >> runRealWorldIO k 141 | handle (Input k) = lift getLine >>= runRealWorldIO . k 142 | 143 | runRealWorldInputT :: (MonadIO m, Typeable m, MonadException m) 144 | => Eff (RealWorldEffect :> e) ~> Eff (Lift (InputT m) :> e) 145 | runRealWorldInputT = freeMap return $ \u -> 146 | transform u runRealWorldInputT handle 147 | where 148 | handle :: (MonadIO m, Typeable m, MonadException m) 149 | => RealWorldEffect (Eff (RealWorldEffect :> e) w) 150 | -> Eff (Lift (InputT m) :> e) w 151 | handle (Print s k) = do 152 | lift (outputStrLn s) 153 | runRealWorldInputT k 154 | handle (Input k) = do 155 | minput <- lift (getInputLine "input> ") 156 | case minput of 157 | Just input -> runRealWorldInputT . k $ input 158 | Nothing -> undefined -- TODO: handle properly 159 | 160 | transform :: (Typeable t, Typeable s, Functor s) 161 | => Union (t :> r) v -- ^ Request 162 | -> (v -> Eff (s :> r) a) -- ^ Relay the request 163 | -> (t v -> Eff (s :> r) a) -- ^ Handle the request of type t 164 | -> Eff (s :> r) a 165 | transform u loop h = either passOn h $ decomp u 166 | where 167 | passOn u' = E.send (weaken u') >>= loop 168 | 169 | runIO :: State -> Program -> IO (Either Error (State, ())) 170 | runIO s = runLift . runRealWorldIO . runExc 171 | . runStateEffect s . unProgram 172 | 173 | runInputT :: (MonadIO m, Typeable m, MonadException m) 174 | => State -> Program -> InputT m (Either Error (State, ())) 175 | runInputT s = runLift . runRealWorldInputT . runExc 176 | . runStateEffect s . unProgram 177 | -------------------------------------------------------------------------------- /src/UI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, FlexibleContexts #-} 2 | module UI where 3 | 4 | import System.Console.Haskeline 5 | import qualified System.Console.Haskeline.Brick as HB 6 | 7 | import Brick 8 | import Brick.BChan 9 | import qualified Brick.Widgets.Center as C 10 | import qualified Brick.Widgets.Border as B 11 | import qualified Graphics.Vty as V 12 | 13 | import Parser 14 | import Meaning 15 | import qualified Runner as R 16 | 17 | import Data.Foldable (traverse_) 18 | import Data.List (isPrefixOf) 19 | import qualified Data.Map.Lazy as M 20 | 21 | import Control.Monad (void) 22 | import Control.Monad.State.Lazy 23 | import Control.Concurrent (forkFinally) 24 | 25 | import Control.Monad.IO.Class (liftIO, MonadIO) 26 | import System.Directory (getAppUserDataDirectory) 27 | 28 | import Data.Maybe (fromMaybe) 29 | 30 | data Event = StateUpdated R.State 31 | | FromHBWidget HB.ToBrick 32 | | HaskelineDied (Either SomeException ()) 33 | 34 | data AppName = TheApp | HaskelineWidget | StackViewport 35 | deriving (Ord, Eq, Show) 36 | 37 | data AppState = AppState { haskelineWidget :: HB.Widget AppName 38 | , joyState :: Maybe R.State 39 | } 40 | 41 | initialAppState :: AppState 42 | initialAppState = 43 | AppState { haskelineWidget = HB.initialWidget HaskelineWidget 44 | , joyState = Nothing 45 | } 46 | 47 | app :: HB.Config Event -> App AppState Event AppName 48 | app c = App { appDraw = drawUI 49 | , appChooseCursor = \_ -> showCursorNamed HaskelineWidget 50 | , appHandleEvent = handleEvent c 51 | , appStartEvent = return 52 | , appAttrMap = const theMap 53 | } 54 | 55 | handleEvent :: HB.Config Event 56 | -> AppState -> BrickEvent AppName Event 57 | -> EventM AppName (Next AppState) 58 | handleEvent c s@AppState{haskelineWidget = hw} e = do 59 | hw' <- HB.handleEvent c hw e 60 | handleAppEvent (s { haskelineWidget = hw' }) e 61 | 62 | handleAppEvent :: AppState -> BrickEvent AppName Event 63 | -> EventM AppName (Next AppState) 64 | handleAppEvent s (AppEvent (HaskelineDied e)) = halt s 65 | handleAppEvent s (AppEvent (StateUpdated st)) = continue $ 66 | s { joyState = Just st } 67 | handleAppEvent s _ = continue s 68 | 69 | drawUI :: AppState -> [Widget AppName] 70 | drawUI s = [HB.render (haskelineWidget s) <+> stackWidget] 71 | where 72 | stackWidget = 73 | B.border $ hLimit 20 $ viewport StackViewport Vertical $ 74 | vBox $ (map $ str . show) $ 75 | fromMaybe [] (R.stack <$> joyState s) 76 | 77 | theMap :: AttrMap 78 | theMap = attrMap V.defAttr [] 79 | 80 | runTui :: IO () 81 | runTui = do 82 | chan <- newBChan 10 83 | config <- HB.configure 84 | chan 85 | FromHBWidget 86 | (\case { FromHBWidget x -> Just x; _ -> Nothing }) 87 | 88 | _ <- forkFinally 89 | (runTuiInputT config chan) 90 | (writeBChan chan . HaskelineDied) 91 | void $ customMain 92 | (V.mkVty V.defaultConfig) 93 | (Just chan) 94 | (app config) 95 | initialAppState 96 | 97 | runTuiInputT :: HB.Config Event -> BChan Event -> IO () 98 | runTuiInputT c chan = do 99 | hs <- haskelineSettings 100 | (flip evalStateT) R.initialState . runInputTBehavior (HB.useBrick c) hs $ loop 101 | where 102 | loop :: InputT (StateT R.State IO) () 103 | loop = do 104 | minput <- getInputLine "> " 105 | case minput of 106 | Just unparsed -> doParsing unparsed 107 | Nothing -> return () 108 | 109 | doParsing :: String -> InputT (StateT R.State IO) () 110 | doParsing unparsed = 111 | case parse unparsed of 112 | Right parsed -> do 113 | s <- lift get 114 | x <- R.runInputT s . meaning $ parsed 115 | case x of 116 | Right (s', ()) -> do 117 | lift (put s') 118 | liftIO $ writeBChan chan $ StateUpdated s' 119 | loop 120 | Left e -> (outputStrLn $ show e) >> loop 121 | Left e -> outputStrLn e >> loop 122 | 123 | runRepl :: IO () 124 | runRepl = do 125 | hs <- haskelineSettings 126 | (flip evalStateT) R.initialState . runInputT hs $ loop 127 | where 128 | loop :: InputT (StateT R.State IO) () 129 | loop = do 130 | minput <- getInputLine "> " 131 | case minput of 132 | Just (':' : 's' : _) -> dumpStack 133 | Just unparsed -> doParsing unparsed 134 | Nothing -> return () 135 | 136 | dumpStack = do 137 | s <- lift get 138 | traverse_ (outputStrLn . show) (R.stack s) 139 | loop 140 | 141 | doParsing :: String -> InputT (StateT R.State IO) () 142 | doParsing unparsed = 143 | case parse unparsed of 144 | Right parsed -> do 145 | s <- lift get 146 | x <- R.runInputT s . meaning $ parsed 147 | case x of 148 | Right (s', ()) -> lift (put s') >> loop 149 | Left e -> (outputStrLn $ show e) >> loop 150 | Left e -> (outputStrLn e) >> loop 151 | 152 | 153 | -- Leverage the MonadException from haskeline and the StateT 154 | -- from mtl. 155 | -- This piece of code is taken verbatim from here: 156 | -- https://hackage.haskell.org/package/haskeline-0.7.4.0/docs/src/System.Console.Haskeline.MonadException.html#line-152 157 | instance MonadException m => MonadException (StateT s m) where 158 | controlIO f = StateT $ \s -> controlIO $ \run -> 159 | fmap (flip runStateT s) $ f $ stateRunIO s run 160 | where 161 | stateRunIO :: s -> RunIO m -> RunIO (StateT s m) 162 | stateRunIO s (RunIO run) = RunIO (\m -> fmap (StateT . const) 163 | $ run (runStateT m s)) 164 | 165 | haskelineSettings :: (MonadState R.State m, MonadIO m) 166 | => IO (Settings m) 167 | haskelineSettings = do 168 | hf <- getAppUserDataDirectory "silly-joy.history" 169 | return $ Settings { historyFile = Just hf 170 | , complete = completer 171 | , autoAddHistory = True 172 | } 173 | where completer = completeWord Nothing [' ', '\t'] $ \w -> do 174 | s <- get 175 | return $ map simpleCompletion 176 | $ filter (isPrefixOf w) . M.keys . R.dict 177 | $ s 178 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.23 2 | 3 | packages: 4 | - '.' 5 | - location: 6 | git: https://github.com/rootmos/haskeline.git 7 | commit: bcd94f5cc0c4e919cbda3bb43dde482cac56dd51 8 | 9 | flags: 10 | haskeline: 11 | brick: true 12 | 13 | extra-package-dbs: [] 14 | 15 | system-ghc: true 16 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Main where 3 | 4 | import Test.Hspec 5 | import Control.Exception 6 | 7 | import Parser 8 | import Meaning 9 | import Runner 10 | 11 | main :: IO () 12 | main = hspec $ do 13 | spec_parser 14 | spec_simulate 15 | 16 | spec_parser = 17 | describe "parse" $ do 18 | it "should parse empty string " $ do 19 | parse "" `shouldBe` Right [] 20 | 21 | it "should parse: foo" $ do 22 | parse "foo" `shouldBe` Right [Word "foo"] 23 | 24 | it "should parse: foo" $ do 25 | parse " foo" `shouldBe` Right [Word "foo"] 26 | 27 | it "should parse: foo (trailing space)" $ do 28 | parse "foo " `shouldBe` Right [Word "foo"] 29 | 30 | it "should parse: \"foo\"" $ do 31 | parse "\"foo\"" `shouldBe` Right [Str "foo"] 32 | 33 | it "should parse: \"foo \\\"bar\\\"\"" $ do 34 | parse "\"foo \\\"bar\\\"\"" `shouldBe` Right [Str "foo \"bar\""] 35 | 36 | it "should parse: 1" $ do parse "1" `shouldBe` Right [Number 1] 37 | it "should parse: 0" $ do parse "0" `shouldBe` Right [Number 0] 38 | it "should parse: -7" $ do parse "-7" `shouldBe` Right [Number (-7)] 39 | 40 | it "should parse: +" $ do parse "+" `shouldBe` Right [Word "+"] 41 | it "should parse: -" $ do parse "-" `shouldBe` Right [Word "-"] 42 | it "should parse: *" $ do parse "*" `shouldBe` Right [Word "*"] 43 | it "should parse: /" $ do parse "/" `shouldBe` Right [Word "/"] 44 | it "should parse: %" $ do parse "%" `shouldBe` Right [Word "%"] 45 | it "should parse: =" $ do parse "=" `shouldBe` Right [Word "="] 46 | it "should parse: !=" $ do parse "!=" `shouldBe` Right [Word "!="] 47 | it "should parse: <" $ do parse "<" `shouldBe` Right [Word "<"] 48 | it "should parse: >" $ do parse ">" `shouldBe` Right [Word ">"] 49 | it "should parse: <=" $ do parse "<=" `shouldBe` Right [Word "<="] 50 | it "should parse: >=" $ do parse ">=" `shouldBe` Right [Word ">="] 51 | 52 | it "should parse: foo bar" $ do 53 | parse "foo bar" `shouldBe` Right 54 | [Word "foo", Word "bar"] 55 | 56 | it "should parse: []" $ do 57 | parse "[]" `shouldBe` Right [Quoted []] 58 | 59 | it "should parse: []" $ do 60 | parse " []" `shouldBe` Right [Quoted []] 61 | 62 | it "should parse: [] (trailing space)" $ do 63 | parse "[] " `shouldBe` Right [Quoted []] 64 | 65 | it "should parse: [ ]" $ do 66 | parse "[ ]" `shouldBe` Right [Quoted []] 67 | 68 | it "should parse: [foo]" $ do 69 | parse "[foo]" `shouldBe` Right 70 | [Quoted [Word "foo"]] 71 | 72 | it "should parse: [foo] bar" $ do 73 | parse "[foo] bar" `shouldBe` Right 74 | [Quoted [Word "foo"], Word "bar"] 75 | 76 | it "should parse: [ foo bar ]" $ do 77 | parse "[ foo bar ]" `shouldBe` Right 78 | [Quoted [Word "foo", Word "bar"]] 79 | 80 | it "should parse: [[foo]]" $ do 81 | parse "[[foo]]" `shouldBe` Right 82 | [Quoted [Quoted [Word "foo"]]] 83 | 84 | it "should parse: [[foo] bar]" $ do 85 | parse "[[foo] bar]" `shouldBe` Right 86 | [Quoted [Quoted [Word "foo"], Word "bar"]] 87 | 88 | it "should parse: x := 7; x" $ do 89 | parse "x := 7; x" `shouldBe` Right 90 | [Binding "x" [Number 7], Word "x"] 91 | 92 | it "should parse: x := 7" $ do 93 | parse "x := 7" `shouldBe` Right 94 | [Binding "x" [Number 7]] 95 | 96 | it "should parse: x := 7;" $ do 97 | parse "x := 7;" `shouldBe` Right 98 | [Binding "x" [Number 7]] 99 | 100 | it "should parse: x;" $ do 101 | parse "x;" `shouldBe` Right [Word "x"] 102 | 103 | it "should parse: x; y" $ do 104 | parse "x; y" `shouldBe` Right [Word "x", Word "y"] 105 | 106 | it "should parse: x ;y" $ do 107 | parse "x ;y" `shouldBe` Right [Word "x", Word "y"] 108 | 109 | it "should parse: x ; y" $ do 110 | parse "x ; y" `shouldBe` Right [Word "x", Word "y"] 111 | 112 | spec_simulate = 113 | describe "simulate" $ do 114 | it "should simulate empty string" $ do 115 | let (State { stack = st }) = simulateUnsafe "" [] 116 | st `shouldBe` [] 117 | it "should simulate: 1" $ do 118 | let (State { stack = st }) = simulateUnsafe "1" [] 119 | st `shouldBe` [I 1] 120 | it "should simulate: 1 pop" $ do 121 | let (State { stack = st }) = simulateUnsafe "1 pop" [] 122 | st `shouldBe` [] 123 | it "should simulate: 2 dup" $ do 124 | let (State { stack = st }) = simulateUnsafe "2 dup" [] 125 | st `shouldBe` [I 2, I 2] 126 | it "should simulate: pop" $ do 127 | evaluate (simulateUnsafe "pop" []) 128 | `shouldThrow` (== PoppingEmptyStack) 129 | it "should simulate: foo" $ do 130 | evaluate (simulateUnsafe "foo" []) 131 | `shouldThrow` (== Undefined "foo") 132 | it "should simulate: 1 2" $ do 133 | let (State { stack = st }) = simulateUnsafe "1 2" [] 134 | st `shouldBe` [I 2, I 1] 135 | it "should simulate: 1 2 +" $ do 136 | let (State { stack = st }) = simulateUnsafe "1 2 +" [] 137 | st `shouldBe` [I 3] 138 | it "should simulate: 1 2 -" $ do 139 | let (State { stack = st }) = simulateUnsafe "1 2 -" [] 140 | st `shouldBe` [I (-1)] 141 | it "should simulate: 3 4 *" $ do 142 | let (State { stack = st }) = simulateUnsafe "3 4 *" [] 143 | st `shouldBe` [I 12] 144 | it "should simulate: 1 +" $ do 145 | evaluate (simulateUnsafe "1 +" []) 146 | `shouldThrow` (== PoppingEmptyStack) 147 | 148 | it "should simulate: 7 2 /" $ do 149 | stack (simulateUnsafe "7 2 /" []) `shouldBe` [I 3] 150 | it "should simulate: 7 2 %" $ do 151 | stack (simulateUnsafe "7 2 %" []) `shouldBe` [I 1] 152 | it "should simulate: 7 2 div" $ do 153 | stack (simulateUnsafe "7 2 div" []) `shouldBe` [I 1, I 3] 154 | 155 | it "should simulate: 7 print" $ do 156 | let (State { stack = st }) = simulateUnsafe "7 print" [expect "7"] 157 | st `shouldBe` [] 158 | it "should simulate: [foo]" $ do 159 | let (State { stack = st }) = simulateUnsafe "[foo]" [] 160 | length st `shouldBe` 1 161 | it "should simulate: 7 [dup] i" $ do 162 | stack (simulateUnsafe "7 [dup] i" []) `shouldBe` [I 7, I 7] 163 | it "should simulate: [[7]] i i" $ do 164 | stack (simulateUnsafe "[[7]] i i" []) `shouldBe` [I 7] 165 | it "should simulate: [[7 8] dup] i dip i" $ do 166 | stack (simulateUnsafe "[[7 8] dup] i dip i" []) 167 | `shouldBe` [I 8, I 7, I 8, I 7] 168 | it "should simulate: [[7 8] dup] i b" $ do 169 | stack (simulateUnsafe "[[7 8] dup] i b" []) 170 | `shouldBe` [I 8, I 7, I 8, I 7] 171 | it "should simulate: [foo] +" $ do 172 | evaluate (simulateUnsafe "[foo] +" []) 173 | `shouldThrow` (\case {TypeMismatch _ _ -> True; _ -> False}) 174 | it "should simulate: [foo] 1 +" $ do 175 | evaluate (simulateUnsafe "[foo] 1 +" []) 176 | `shouldThrow` (\case {TypeMismatch _ _ -> True; _ -> False}) 177 | it "should simulate: 1 i" $ do 178 | evaluate (simulateUnsafe "1 i" []) 179 | `shouldThrow` (\case {TypeMismatch _ _ -> True; _ -> False}) 180 | 181 | it "should simulate: 2 3 4 [+] dip" $ do 182 | stack (simulateUnsafe "2 3 4 [+] dip" []) `shouldBe` [I 4, I 5] 183 | 184 | it "should simulate: [foo] dip" $ do 185 | evaluate (simulateUnsafe "[foo] dip" []) 186 | `shouldThrow` (== PoppingEmptyStack) 187 | it "should simulate: [foo] 1 dip" $ do 188 | evaluate (simulateUnsafe "[foo] 1 dip" []) 189 | `shouldThrow` (\case {TypeMismatch _ _ -> True; _ -> False}) 190 | 191 | it "should simulate: 1 2 <" $ do 192 | stack (simulateUnsafe "1 2 <" []) `shouldBe` [B True] 193 | it "should simulate: 2 2 <" $ do 194 | stack (simulateUnsafe "2 2 <" []) `shouldBe` [B False] 195 | 196 | it "should simulate: 2 1 >" $ do 197 | stack (simulateUnsafe "2 1 >" []) `shouldBe` [B True] 198 | it "should simulate: 2 2 >" $ do 199 | stack (simulateUnsafe "2 2 >" []) `shouldBe` [B False] 200 | 201 | it "should simulate: 3 1 >=" $ do 202 | stack (simulateUnsafe "3 1 >=" []) `shouldBe` [B True] 203 | it "should simulate: 1 3 >=" $ do 204 | stack (simulateUnsafe "1 3 >=" []) `shouldBe` [B False] 205 | it "should simulate: 2 2 >=" $ do 206 | stack (simulateUnsafe "2 2 >=" []) `shouldBe` [B True] 207 | 208 | it "should simulate: 3 1 <=" $ do 209 | stack (simulateUnsafe "3 1 <=" []) `shouldBe` [B False] 210 | it "should simulate: 1 3 <=" $ do 211 | stack (simulateUnsafe "1 3 <=" []) `shouldBe` [B True] 212 | it "should simulate: 2 2 <=" $ do 213 | stack (simulateUnsafe "2 2 <=" []) `shouldBe` [B True] 214 | 215 | it "should simulate: 1 2 =" $ do 216 | stack (simulateUnsafe "1 2 =" []) `shouldBe` [B False] 217 | it "should simulate: 2 2 =" $ do 218 | stack (simulateUnsafe "2 2 =" []) `shouldBe` [B True] 219 | 220 | it "should simulate: 1 2 !=" $ do 221 | stack (simulateUnsafe "1 2 !=" []) `shouldBe` [B True] 222 | it "should simulate: 2 2 !=" $ do 223 | stack (simulateUnsafe "2 2 !=" []) `shouldBe` [B False] 224 | 225 | it "should simulate: true" $ do 226 | stack (simulateUnsafe "true" []) `shouldBe` [B True] 227 | it "should simulate: false" $ do 228 | stack (simulateUnsafe "false" []) `shouldBe` [B False] 229 | 230 | it "should simulate: false false or" $ do 231 | stack (simulateUnsafe "false false or" []) `shouldBe` [B False] 232 | it "should simulate: true false or" $ do 233 | stack (simulateUnsafe "true false or" []) `shouldBe` [B True] 234 | it "should simulate: false true or" $ do 235 | stack (simulateUnsafe "false true or" []) `shouldBe` [B True] 236 | it "should simulate: true true or" $ do 237 | stack (simulateUnsafe "true true or" []) `shouldBe` [B True] 238 | 239 | it "should simulate: false false and" $ do 240 | stack (simulateUnsafe "false false and" []) `shouldBe` [B False] 241 | it "should simulate: true false and" $ do 242 | stack (simulateUnsafe "true false and" []) `shouldBe` [B False] 243 | it "should simulate: false true and" $ do 244 | stack (simulateUnsafe "false true and" []) `shouldBe` [B False] 245 | it "should simulate: true true and" $ do 246 | stack (simulateUnsafe "true true and" []) `shouldBe` [B True] 247 | 248 | it "should simulate: false not" $ do 249 | stack (simulateUnsafe "false not" []) `shouldBe` [B True] 250 | it "should simulate: true not" $ do 251 | stack (simulateUnsafe "true not" []) `shouldBe` [B False] 252 | 253 | it "should simulate: [1 1 =] [7] [8] ifte" $ do 254 | stack (simulateUnsafe "[1 1 =] [7] [8] ifte" []) `shouldBe` [I 7] 255 | it "should simulate: [1 2 =] [7] [8] ifte" $ do 256 | stack (simulateUnsafe "[1 2 =] [7] [8] ifte" []) `shouldBe` [I 8] 257 | it "should simulate: 1 1 [=] [7] [8] ifte" $ do 258 | stack (simulateUnsafe "1 1 [=] [7] [8] ifte" []) 259 | `shouldBe` [I 7, I 1, I 1] 260 | it "should simulate: 1 2 [=] [7] [8] ifte" $ do 261 | stack (simulateUnsafe "1 2 [=] [7] [8] ifte" []) 262 | `shouldBe` [I 8, I 2, I 1] 263 | 264 | it "should simulate: 0 null" $ do 265 | stack (simulateUnsafe "0 null" []) `shouldBe` [B True] 266 | it "should simulate: 1 null" $ do 267 | stack (simulateUnsafe "1 null" []) `shouldBe` [B False] 268 | it "should simulate: [] null" $ do 269 | stack (simulateUnsafe "[] null" []) `shouldBe` [B True] 270 | it "should simulate: [1] null" $ do 271 | stack (simulateUnsafe "[1] null" []) `shouldBe` [B False] 272 | 273 | it "should simulate: 0 small" $ do 274 | stack (simulateUnsafe "0 small" []) `shouldBe` [B True] 275 | it "should simulate: 1 small" $ do 276 | stack (simulateUnsafe "1 small" []) `shouldBe` [B True] 277 | it "should simulate: 2 small" $ do 278 | stack (simulateUnsafe "2 small" []) `shouldBe` [B False] 279 | it "should simulate: [] small" $ do 280 | stack (simulateUnsafe "[] small" []) `shouldBe` [B True] 281 | it "should simulate: [1] small" $ do 282 | stack (simulateUnsafe "[1] small" []) `shouldBe` [B True] 283 | it "should simulate: [1 2] small" $ do 284 | stack (simulateUnsafe "[1 2] small" []) `shouldBe` [B False] 285 | 286 | it "should simulate: 0 succ" $ do 287 | stack (simulateUnsafe "0 succ" []) `shouldBe` [I 1] 288 | it "should simulate: 1 pred" $ do 289 | stack (simulateUnsafe "1 pred" []) `shouldBe` [I 0] 290 | 291 | it "should simulate: 1 2 swap" $ do 292 | stack (simulateUnsafe "1 2 swap" []) `shouldBe` [I 1, I 2] 293 | 294 | it "should simulate: [1 2] i" $ do 295 | stack (simulateUnsafe "[1 2] i" []) `shouldBe` [I 2, I 1] 296 | 297 | it "should simulate: 1 2 [+] I" $ do 298 | stack (simulateUnsafe "1 2 [+] I" []) `shouldBe` [I 3, I 2, I 1] 299 | 300 | it "should simulate: 1 2 3 [pop + 7 swap] I" $ do 301 | stack (simulateUnsafe "1 2 3 [pop + 7 swap] I" []) 302 | `shouldBe` [I 3, I 3, I 2, I 1] 303 | 304 | it "should simulate: [1] [2] concat i" $ do 305 | stack (simulateUnsafe "[1] [2] concat i" []) `shouldBe` [I 2, I 1] 306 | 307 | it "should simulate: [1] [2] b" $ do 308 | stack (simulateUnsafe "[1] [2] b" []) `shouldBe` [I 2, I 1] 309 | 310 | 311 | it "should simulate: 1 [2] cons i" $ do 312 | stack (simulateUnsafe "1 [2] cons i" []) `shouldBe` [I 2, I 1] 313 | 314 | 315 | it "should simulate: [1] first" $ do 316 | stack (simulateUnsafe "[1] first" []) `shouldBe` [I 1] 317 | 318 | it "should simulate: [1 2] first" $ do 319 | stack (simulateUnsafe "[1 2] first" []) `shouldBe` [I 1] 320 | 321 | it "should simulate: [] first" $ do 322 | evaluate (simulateUnsafe "[] first" []) 323 | `shouldThrow` (== EmptyAggregate) 324 | 325 | it "should simulate: 1 [] cons [] cons first first" $ do 326 | stack (simulateUnsafe "1 [] cons [] cons first first" []) 327 | `shouldBe` [I 1] 328 | 329 | it "should simulate: 1 2 [+ 4] first" $ do 330 | stack (simulateUnsafe "1 2 [+ 4] first" []) `shouldBe` [I 3] 331 | 332 | 333 | it "should simulate: [] size" $ do 334 | stack (simulateUnsafe "[] size" []) `shouldBe` [I 0] 335 | 336 | it "should simulate: [1 2] size" $ do 337 | stack (simulateUnsafe "[1 2] size" []) `shouldBe` [I 2] 338 | 339 | 340 | it "should simulate: [] rest" $ do 341 | evaluate (simulateUnsafe "[] rest" []) 342 | `shouldThrow` (== EmptyAggregate) 343 | 344 | it "should simulate: [1] rest i" $ do 345 | stack (simulateUnsafe "[1] rest i" []) `shouldBe` [] 346 | 347 | it "should simulate: [1 2] rest i" $ do 348 | stack (simulateUnsafe "[1 2] rest i" []) `shouldBe` [I 2] 349 | 350 | it "should simulate: [1 2 3] rest i" $ do 351 | stack (simulateUnsafe "[1 2 3] rest i" []) `shouldBe` [I 3, I 2] 352 | 353 | 354 | it "should simulate: [] uncons" $ do 355 | evaluate (simulateUnsafe "[] uncons" []) 356 | `shouldThrow` (== EmptyAggregate) 357 | 358 | it "should simulate: [1] uncons size" $ do 359 | stack (simulateUnsafe "[1] uncons size" []) 360 | `shouldBe` [I 0, I 1] 361 | 362 | it "should simulate: [1] uncons i" $ do 363 | stack (simulateUnsafe "[1] uncons i" []) 364 | `shouldBe` [I 1] 365 | 366 | it "should simulate: [1 2 3] uncons size" $ do 367 | stack (simulateUnsafe "[1 2 3] uncons size" []) 368 | `shouldBe` [I 2, I 1] 369 | 370 | it "should simulate: [1 2 3] uncons i" $ do 371 | stack (simulateUnsafe "[1 2 3] uncons i" []) 372 | `shouldBe` [I 3, I 2, I 1] 373 | 374 | it "should simulate: 1 [2] cons uncons i" $ do 375 | stack (simulateUnsafe "1 [2] cons uncons i" []) 376 | `shouldBe` [I 2, I 1] 377 | 378 | it "should simulate: 1 2 [+ 4] uncons i" $ do 379 | stack (simulateUnsafe "1 2 [+ 4] uncons i" []) 380 | `shouldBe` [I 4, I 3] 381 | 382 | it "should simulate factorial example" $ do 383 | stack (flip simulateUnsafe [] $ 384 | "5 [ [pop 0 =] [pop pop 1]" ++ 385 | "[ [dup 1 -] dip dup i * ] ifte ] dup i") `shouldBe` [I 120] 386 | 387 | it "should simulate: \"foo\"" $ do 388 | stack (simulateUnsafe "\"foo\"" []) `shouldBe` [S "foo"] 389 | 390 | it "should simulate: \"foo\" strlen" $ do 391 | stack (simulateUnsafe "\"foo\" strlen" []) `shouldBe` [I 3] 392 | 393 | it "should simulate: 1 strlen" $ do 394 | evaluate (simulateUnsafe "1 strlen" []) 395 | `shouldThrow` (\case {TypeMismatch _ _ -> True; _ -> False}) 396 | 397 | it "should simulate: \"foo\" \"bar\" strcat" $ do 398 | stack (simulateUnsafe "\"foo\" \"bar\" strcat" []) 399 | `shouldBe` [S "foobar"] 400 | 401 | it "should simulate: [+] \"plus\" bind 1 2 plus" $ do 402 | stack (simulateUnsafe "[+] \"plus\" bind 1 2 plus" []) 403 | `shouldBe` [I 3] 404 | 405 | it "should simulate: [1] \"i\" bind i" $ do 406 | stack (simulateUnsafe "[1] \"i\" bind i" []) 407 | `shouldBe` [I 1] 408 | 409 | it "should simulate: [2] \"bind\" bind bind" $ do 410 | stack (simulateUnsafe "[2] \"bind\" bind bind" []) 411 | `shouldBe` [I 2] 412 | 413 | it "should simulate: [[1] \"y\" bind y] I y" $ do 414 | evaluate (simulateUnsafe "[[1] \"y\" bind y] I y" []) 415 | `shouldThrow` (== Undefined "y") 416 | 417 | 418 | it "should simulate: plus := +; 1 2 plus" $ do 419 | stack (simulateUnsafe "plus := +; 1 2 plus" []) 420 | `shouldBe` [I 3] 421 | 422 | it "should simulate: i := 1; i" $ do 423 | stack (simulateUnsafe "i := 1; i" []) 424 | `shouldBe` [I 1] 425 | 426 | it "should simulate: bind := 2; bind" $ do 427 | stack (simulateUnsafe "bind := 2; bind" []) 428 | `shouldBe` [I 2] 429 | 430 | it "should simulate: [y := 1; y] I y" $ do 431 | evaluate (simulateUnsafe "[y := 1; y] I y" []) 432 | `shouldThrow` (== Undefined "y") 433 | 434 | it "should simulate: [x := 1] i x" $ do 435 | stack (simulateUnsafe "[x := 1] i x" []) 436 | `shouldBe` [I 1] 437 | 438 | it "should simulate: [x := 1; 2] i x" $ do 439 | stack (simulateUnsafe "[x := 1; 2] i x" []) 440 | `shouldBe` [I 1, I 2] 441 | 442 | it "should simulate: read_int" $ do 443 | stack (simulateUnsafe "read_int" [send "7"]) `shouldBe` [I 7] 444 | 445 | it "should simulate: read_int" $ do 446 | evaluate (simulateUnsafe "read_int" [send "foo"]) 447 | `shouldThrow` (== UnparseableAsNumber "foo") 448 | 449 | it "should simulate: read_line" $ do 450 | stack (simulateUnsafe "read_line" [send "foo"]) 451 | `shouldBe` [S "foo"] 452 | 453 | it "should simulate: 1 2 3 rolldown" $ do 454 | stack (simulateUnsafe "1 2 3 rolldown" []) 455 | `shouldBe` (reverse [I 2, I 3, I 1]) 456 | 457 | it "should simulate: 1 2 3 rollup" $ do 458 | stack (simulateUnsafe "1 2 3 rollup" []) 459 | `shouldBe` (reverse [I 3, I 1, I 2]) 460 | 461 | it "should simulate: 1 2 3 rotate" $ do 462 | stack (simulateUnsafe "1 2 3 rotate" []) 463 | `shouldBe` (reverse [I 3, I 2, I 1]) 464 | 465 | it "should simulate: [1 2] x rolldown i" $ do 466 | stack (simulateUnsafe "[1 2] x rolldown i" []) 467 | `shouldBe` [I 2, I 1, I 2, I 1] 468 | 469 | it "should simulate: 0 [7] [] primrec" $ do 470 | stack (simulateUnsafe "0 [7] [] primrec" []) 471 | `shouldBe` [I 7] 472 | 473 | it "should simulate: 5 [1] [*] primrec" $ do 474 | stack (simulateUnsafe "5 [1] [*] primrec" []) 475 | `shouldBe` [I 120] 476 | 477 | it "should simulate: 10 [0] [+] primrec" $ do 478 | stack (simulateUnsafe "10 [0] [+] primrec" []) 479 | `shouldBe` [I 55] 480 | 481 | it "should simulate: 0 [null] [succ] [dup pred] [*] linrec" $ do 482 | stack (simulateUnsafe "0 [null] [succ] [dup pred] [*] linrec" []) 483 | `shouldBe` [I 1] 484 | 485 | it "should simulate: 5 [null] [succ] [dup pred] [*] linrec" $ do 486 | stack (simulateUnsafe "5 [null] [succ] [dup pred] [*] linrec" []) 487 | `shouldBe` [I 120] 488 | 489 | it "should simulate: [1] 0 times" $ do 490 | stack (simulateUnsafe "[1] 0 times" []) 491 | `shouldBe` [] 492 | 493 | it "should simulate: [1] 5 times" $ do 494 | stack (simulateUnsafe "[1] 5 times" []) 495 | `shouldBe` [I 1, I 1, I 1, I 1, I 1] 496 | 497 | it "should simulate: clear" $ do 498 | stack (simulateUnsafe "clear" []) `shouldBe` [] 499 | it "should simulate: 1 2 clear" $ do 500 | stack (simulateUnsafe "1 2 clear" []) `shouldBe` [] 501 | 502 | it "should simulate: [1 2 3] [1 +] map i" $ do 503 | stack (simulateUnsafe "[1 2 3] [1 +] map i" []) 504 | `shouldBe` [I 4, I 3, I 2] 505 | 506 | it "should simulate: 1 [] cons [1 +] map i" $ do 507 | stack (simulateUnsafe "1 [] cons [1 +] map i" []) 508 | `shouldBe` [I 2] 509 | 510 | it "should simulate: [1 2 3 4] [2 % null] filter i" $ do 511 | stack (simulateUnsafe "[1 2 3 4] [2 % null] filter i" []) 512 | `shouldBe` [I 4, I 2] 513 | 514 | it "should simulate: 1 [2 3 4] cons [2 % null] filter i" $ do 515 | stack (simulateUnsafe "1 [2 3 4] cons [2 % null] filter i" []) 516 | `shouldBe` [I 4, I 2] 517 | 518 | it "should simulate: [1 2 3 4] 0 [+] fold" $ do 519 | stack (simulateUnsafe "[1 2 3 4] 0 [+] fold" []) 520 | `shouldBe` [I 10] 521 | 522 | it "should simulate: 1 [2 3 4] cons 0 [+] fold" $ do 523 | stack (simulateUnsafe "1 [2 3 4] cons 0 [+] fold" []) 524 | `shouldBe` [I 10] 525 | 526 | 527 | it "should simulate: 1 2 [1 +] app2" $ do 528 | stack (simulateUnsafe "1 2 [1 +] app2" []) 529 | `shouldBe` [I 3, I 2] 530 | 531 | it "should simulate: 1 2 3 [+] app2" $ do 532 | stack (simulateUnsafe "1 2 3 [+] app2" []) 533 | `shouldBe` [I 4, I 3, I 1] 534 | 535 | it "should simulate: 12 [small] [] [pred dup pred] [app2 +] genrec" $ do 536 | stack (simulateUnsafe "12 [small] [] [pred dup pred] [app2 +] genrec" []) 537 | `shouldBe` [I 144] 538 | --------------------------------------------------------------------------------