Skip to content
This repository was archived by the owner on Nov 3, 2020. It is now read-only.

Fixed some hlint warnings #23

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
37 changes: 16 additions & 21 deletions Interp.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,8 @@ import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BSC
import qualified Network.Socket as SO
import Data.List (intercalate)
import Control.Applicative ((<$>))
import Control.Monad (mplus)
import Control.Exception (try, SomeException)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, put)
Expand Down Expand Up @@ -59,11 +61,11 @@ unitv = TupleV []
-- look up a binding from the bottom up
lookup :: Env -> String -> Maybe Value
lookup [] _ = Nothing
lookup (env:xs) name = maybe (lookup xs name) Just (M.lookup name env)
lookup (env:xs) name = M.lookup name env `mplus` lookup xs name

-- bind in the local environment
bind :: Env -> String -> Value -> Env
bind (env:xs) name value = (M.insert name value env):xs
bind (env:xs) name value = M.insert name value env : xs

instance Show Value where
show (IntV i) = show i
Expand Down Expand Up @@ -103,14 +105,10 @@ l ==$ r = BoolV (l == r)
l !=$ r = BoolV (l /= r)

toDict :: M.Map String Value -> Value
toDict m =
let wrapped = map (\(k,v) -> (StrV k, v)) $ M.toAscList m in
DictV $ M.fromAscList wrapped
toDict = DictV . M.mapKeys StrV

fromDict :: M.Map Value Value -> M.Map String Value
fromDict m =
let unwrapped = map (\(StrV k,v) -> (k, v)) $ M.toAscList m in
M.fromAscList unwrapped
fromDict = M.mapKeys (\(StrV s) -> s)

-- some built-in functions

Expand Down Expand Up @@ -148,7 +146,7 @@ _fclose (StreamV handle) = do
liftIO $ hClose handle
return unitv

_sockopen (TupleV [StrV host, IntV port]) = do
_sockopen (TupleV [StrV host, IntV port]) =
liftIO $ SO.withSocketsDo $ do
addr:_ <- SO.getAddrInfo Nothing (Just host) (Just $ show port)
sock <- SO.socket (SO.addrFamily addr) SO.Stream SO.defaultProtocol
Expand All @@ -171,9 +169,7 @@ _ref v = do
value <- liftIO $ newIORef v
return $ RefV value

_readRef (RefV r) = do
value <- liftIO $ readIORef r
return value
_readRef (RefV r) = liftIO $ readIORef r

_setRef (TupleV [RefV r, v]) = do
liftIO $ writeIORef r v
Expand All @@ -193,7 +189,7 @@ _eval (TupleV [StrV code, DictV env]) = do
case ret of
Left err -> return $ TupleV [StrV "err", StrV (show err)]
Right v -> return v
_eval (TupleV [code@(StrV _), (ListV env)]) =
_eval (TupleV [code@(StrV _), ListV env]) =
let env' = map (\(TupleV [k,v]) -> (k,v)) env in
_eval (TupleV [code, DictV $ M.fromList env'])
_eval _ = error "eval: invalid args (want code and environment)"
Expand Down Expand Up @@ -284,8 +280,8 @@ eval (Cons a b) = do
ListV v' -> return $ ListV $ a':v'
_ -> error "cons: RHS must be a list"

eval (ListConst v) = mapM eval v >>= return . ListV
eval (TupleConst v) = mapM eval v >>= return . TupleV
eval (ListConst v) = ListV <$> mapM eval v
eval (TupleConst v) = TupleV <$> mapM eval v

eval (IfExpr c t e) = eval c >>= \cond ->
case cond of
Expand Down Expand Up @@ -314,14 +310,13 @@ eval (Def pat v') = do
case patternBindings pat v of
Nothing -> error $ "pattern binding doesn't satisfy: " ++ show v ++ " with " ++ show pat
Just bindings -> do
put $ (M.union bindings locals):xs -- update our local bindings
put $ M.union bindings locals : xs -- update our local bindings
return v

eval (Lambda pats) = do
env <- get
if length env == 1 then -- if in global env just use [], denoting the current global scope
return $ FnV [] pats
else return $ FnV env pats
let env' = if length env == 1 then [] else env
return $ FnV env' pats

eval (Add l r) = do { l <- eval l; r <- eval r; return $ l +$ r }
eval (Sub l r) = do { l <- eval l; r <- eval r; return $ l -$ r }
Expand Down Expand Up @@ -354,7 +349,7 @@ eval (Call lhs arg) = do
case v of
fn@(FnV cls _) -> do
arg' <- eval arg
let cls' = if cls == [] then [last env] else cls -- if [], use current global env
let cls' = if null cls then [last env] else cls -- if [], use current global env
put cls' -- enter closure env
v <- apply fn arg'
put env -- restore env
Expand Down Expand Up @@ -483,4 +478,4 @@ evalFile path = do
else evalString contents

evalFileV :: FilePath -> IO Value
evalFileV = interpret . evalFile
evalFileV = interpret . evalFile
6 changes: 3 additions & 3 deletions Lamb.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ import System.Environment (getArgs)
import System.Directory (doesFileExist)
import System.FilePath (FilePath, splitExtension)
import Control.Applicative ((<$>))
import Control.Monad (filterM)
import Control.Monad (filterM, void)
import Control.Monad.IO.Class (liftIO)
import Parser (parseProgram)
import Interp (evalFileV, evalProgram, initIO, interpret, InterpState, Value)
Expand All @@ -23,15 +23,15 @@ repl = do
liftIO $ putStr ">> "
line <- liftIO getLine
case parseProgram line of
Left err -> do
Left err ->
liftIO $ putStrLn $ "parse error: " ++ show err
Right prg -> do
ev <- evalProgram prg
liftIO $ print ev
repl

repl' :: IO ()
repl' = interpret repl >> return ()
repl' = void $ interpret repl

main = do
args <- getArgs
Expand Down
12 changes: 12 additions & 0 deletions lamb.cabal
Original file line number Diff line number Diff line change
@@ -0,0 +1,12 @@
name: lamb
version: 0.0.1
synopsis: The Lamb programming language
author: darkf
build-type: Simple
cabal-version: >= 1.8

executable main
main-is: Lamb.hs
build-depends: base, peggy, containers, transformers, directory, filepath, bytestring, network
hs-source-dirs: .
extensions: DoAndIfThenElse