packages feed

miniforth (empty) → 0.1.0.0

raw patch · 9 files changed

+326/−0 lines, 9 filesdep +MonadRandomdep +basedep +containerssetup-changed

Dependencies added: MonadRandom, base, containers, lens, miniforth, mtl, parsec, parsec3-numbers, readline

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Tenor Biel++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lib/MiniForth.hs view
@@ -0,0 +1,11 @@+module MiniForth+    ( module MiniForth.Types+    , module MiniForth.Parser+    , module MiniForth.Engine+    , module MiniForth.StdLib+    ) where++import MiniForth.Types+import MiniForth.Parser+import MiniForth.Engine+import MiniForth.StdLib
+ lib/MiniForth/Engine.hs view
@@ -0,0 +1,35 @@+module MiniForth.Engine+    ( pop+    , push+    , define+    , run+    , word+    ) where++import Control.Monad.Except+import Control.Lens++import MiniForth.Types++pop :: VM Double+pop = use stack >>= go where+    go []     = throwError StackUnderflow+    go (x:xs) = do+        stack .= xs+        return x++push :: Double -> VM ()+push x = stack %= (x:)++define :: String -> VM () -> VM ()+define name block = dict . at name ?= block++run :: [Token] -> VM ()+run []     = return ()+run (x:xs) = case x of+    Word w   -> word w >> run xs+    Number n -> push n >> run xs+    Def w b  -> define w (run b) >> run xs++word :: String -> VM ()+word w = use (dict . at w) >>= maybe (throwError (UndefinedWord w)) id
+ lib/MiniForth/Parser.hs view
@@ -0,0 +1,36 @@+module MiniForth.Parser+    ( programParser+    ) where++import Text.Parsec.Number+import Text.Parsec++import MiniForth.Types++programParser :: Parsec String () [Token]+programParser = do+    ts <- tokenParser `sepEndBy` spaces+    eof+    return ts++tokenParser :: Parsec String () Token+tokenParser = wordParser <|> numberParser <|> defParser where+    specials = oneOf "!#$%&|*+-/<=>?@^_~."++    wordParser = fmap Word wordp++    wordp = do+        c <- letter <|> specials+        cs <- many (letter <|> specials <|> digit <|> char ':')+        return (c:cs)++    numberParser = fmap Number (floating3 True)++    defParser = do+        _ <- char ':'+        spaces+        w <- wordp+        spaces+        ws <- tokenParser `sepEndBy` spaces+        _ <- char ';'+        return (Def w ws)
+ lib/MiniForth/StdLib.hs view
@@ -0,0 +1,95 @@+module MiniForth.StdLib+    ( load+    ) where++import Control.Monad.Random+import Control.Monad.Except+import Control.Applicative+import Control.Lens+import Data.Fixed           (mod', div')++import MiniForth.Engine+import MiniForth.Types++load :: VM ()+load = do+    define "."     $ pop >>= output+    define "rand"  $ getRandomR (0, 1) >>= push+    define "pick"  $ popI >>= pick+    define "roll"  $ popI >>= roll+    define "rot"   $ roll 2+    define "drop"  $ pop >> return ()+    define "over"  $ pick 1+    define "swap"  $ roll 1+    define "dup"   $ pick 0+    define "2dup"  $ twodup+    define "+"     $ twomap (+)+    define "-"     $ twomap (-)+    define "*"     $ twomap (*)+    define "/"     $ twomap (/)+    define "%"     $ twomap mod'+    define "="     $ bwomap (==)+    define ">"     $ bwomap (>)+    define "<"     $ bwomap (<)+    define ">="    $ bwomap (>=)+    define "<="    $ bwomap (<=)+    define "min"   $ twomap min+    define "max"   $ twomap max+    define "and"   $ twomap and'+    define "or"    $ twomap or'+    define "atan2" $ twomap atan2+    define "^"     $ liftA2 (flip (^^)) popI pop >>= push+    define "sqrt"  $ topmap sqrt+    define "sin"   $ topmap sin+    define "cos"   $ topmap sin+    define "tan"   $ topmap tan+    define "neg"   $ topmap negate+    define "log"   $ topmap log+    define "ceil"  $ iopmap ceiling+    define "floor" $ iopmap floor+    define "round" $ iopmap round++popI :: VM Int+popI = round <$> pop++pick :: Int -> VM ()+pick n = use stack >>= go where+    go = maybe (throwError (AddressOutOfBounds n)) push . ind n+    ind _ []     = Nothing+    ind 0 (x:_)  = Just x+    ind i (_:xs) = ind (pred i) xs++roll :: Int -> VM ()+roll n = uses stack (splitAt n) >>= go where+    go (xs, y:ys) = stack .= (y:xs ++ ys)+    go (_,  [])   = throwError (AddressOutOfBounds n)++twodup :: VM ()+twodup = pick 2 >> pick 2++output :: Double -> VM ()+output n = liftIO $ putStrLn s where+    s = if n `mod'` 1 == 0 then show (n `div'` 1 :: Int) else show n++twomap :: (Double -> Double -> Double) -> VM ()+twomap f = liftA2 (flip f) pop pop >>= push++topmap :: (Double -> Double) -> VM ()+topmap f = f <$> pop >>= push++iopmap :: (Double -> Int) -> VM ()+iopmap f = f <$> pop >>= push . fromIntegral++and' :: Double -> Double -> Double+and' 0 _ = 0+and' _ 0 = 0+and' _ _ = 1++or' :: Double -> Double -> Double+or' 0 0 = 0+or' _ _ = 1++bwomap :: (Double -> Double -> Bool) -> VM ()+bwomap f = liftA2 (\x y -> fromB $ f y x) pop pop >>= push where+    fromB True = 1+    fromB False = 0
+ lib/MiniForth/Types.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving #-}++module MiniForth.Types+    ( VM(..)+    , Token(..)+    , World(..)+    , Err(..)+    , stack+    , dict+    ) where++import Control.Monad.Random+import Control.Monad.Except+import Control.Monad.State+import Control.Applicative+import Control.Lens++import qualified Data.Map as M++data Token+    = Word String+    | Number Double+    | Def String [Token]++newtype VM a = VM { runVM :: ExceptT Err (StateT World IO) a }+    deriving ( Functor+             , Applicative+             , Monad+             , MonadState World+             , MonadError Err+             , MonadRandom+             , MonadIO+             )++data Err+    = StackUnderflow+    | UndefinedWord String+    | AddressOutOfBounds Int+    | ProgramExit++instance Show Err where+    show StackUnderflow         = "stack underflow"+    show (UndefinedWord w)      = "undefined word \"" ++ w ++ "\""+    show (AddressOutOfBounds i) = "address " ++ show i ++ " out of bounds"+    show ProgramExit            = "exit"++data World = World+    { _stack :: [Double]+    , _dict  :: M.Map String (VM ())+    }++makeLenses ''World
+ miniforth.cabal view
@@ -0,0 +1,45 @@+name:                miniforth+version:             0.1.0.0+synopsis:            Miniature FORTH-like interpreter+description:         Miniature FORTH-like interpreter for muno+license:             MIT+license-file:        LICENSE+author:              Tenor Biel+maintainer:          tenorbiel@gmail.com+category:            Language+build-type:          Simple+cabal-version:       >=1.10++source-repository head+  type:              git+  location:          https://github.com/L8D/miniforth.git++library+  ghc-options:         -Wall+  exposed-modules:     MiniForth,+                       MiniForth.Types,+                       MiniForth.Parser,+                       MiniForth.Engine,+                       MiniForth.StdLib+  build-depends:       base >=4.7 && <4.8,+                       mtl >=2.2 && <2.3,+                       lens >=4.7 && <4.8,+                       parsec >=3.1 && <3.2,+                       parsec3-numbers >=0.1 && <0.2,+                       MonadRandom >=0.3 && <0.4,+                       containers >=0.5 && <0.6+  hs-source-dirs:      lib+  default-language:    Haskell2010++executable miniforth+  ghc-options:         -Wall+  main-is:             Main.hs+  build-depends:       base,+                       mtl,+                       lens,+                       parsec,+                       containers,+                       readline >=1.0.3 && <1.0.4,+                       miniforth+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Main.hs view
@@ -0,0 +1,30 @@+module Main+    ( main+    ) where++import System.Console.Readline+import Control.Monad.Except+import Control.Monad.State+import Text.Parsec++import qualified Data.Map as M++import MiniForth++main :: IO ()+main = withWorld (World [] M.empty) (load >> repl)++withWorld :: World -> VM () -> IO ()+withWorld w r = runStateT (runExceptT (runVM r)) w >>= go where+    go (Left ProgramExit, _) = return ()+    go (Left e, s)           = liftIO (print e) >> withWorld s repl+    go (Right (), _)         = return ()++repl :: VM ()+repl = liftIO (readline "% ") >>= maybe (liftIO $ putStrLn "") go where+    go line = do+        liftIO $ addHistory line+        case parse programParser "" line of+            Left e   -> liftIO $ print e+            Right xs -> run xs+        repl