swearjure (empty) → 1.0.0
raw patch · 10 files changed
+1560/−0 lines, 10 filesdep +attoparsecdep +basedep +containerssetup-changed
Dependencies added: attoparsec, base, containers, fixplate, mtl, pretty, random, random-shuffle, readline, system-fileio, system-filepath, text
Files
- COPYING.LESSER +181/−0
- Setup.hs +2/−0
- src/Main.hs +143/−0
- src/Swearjure/AST.hs +238/−0
- src/Swearjure/Errors.hs +23/−0
- src/Swearjure/Eval.hs +269/−0
- src/Swearjure/Parser.hs +256/−0
- src/Swearjure/Primitives.hs +248/−0
- src/Swearjure/Reader.hs +158/−0
- swearjure.cabal +42/−0
+ COPYING.LESSER view
@@ -0,0 +1,181 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.++--------------------------------------------------------------------------------++ SPECIAL EXCEPTION GRANTED BY COPYRIGHT HOLDERS++As a special exception, copyright holders give you permission to link this+library with independent modules to produce an executable, regardless of+the license terms of these independent modules, and to copy and distribute+the resulting executable under terms of your choice, provided that you also+meet, for each linked independent module, the terms and conditions of+the license of that module. An independent module is a module which is not+derived from or based on this library. If you modify this library, you must+extend this exception to your version of the library.++Note: this exception relieves you of any obligations under sections 4 and 5+of this license, and section 6 of the GNU General Public License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Main.hs view
@@ -0,0 +1,143 @@+{-# OPTIONS_GHC -Wall -Werror #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative ((<$>))+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Data.Foldable (toList)+import Data.Sequence+import qualified Data.Sequence as S+import qualified Data.Text.Lazy as B+import Filesystem hiding (readFile, writeFile)+import Filesystem.Path.CurrentOS+import Swearjure.AST (prStr, Val, EvalState, _nil)+import Swearjure.Errors+import Swearjure.Eval (initEnv, eval)+import Swearjure.Parser+import Swearjure.Reader+import System.Console.Readline (readline, addHistory)+import System.Environment+import System.IO (hIsTerminalDevice, stdin)++main :: IO ()+main = do args <- getArgs+ case args of+ ["-h"] -> banner+ ["-?"] -> banner+ ["--help"] -> banner+ [x] -> do contents <- readFile x+ static contents+ [] -> do isTerm <- hIsTerminalDevice stdin+ if isTerm+ then interactive+ else do contents <- getContents+ static contents+ _ -> banner++banner :: IO ()+banner = putStrLn "Swearjure, version (*).(+).(+) (aka 1.0.0)"++-- Since attoparsec+static :: String -> IO ()+static input = staticRep 1 (readStatic $ B.pack input)++staticRep :: Int -> [Either SwjError PVal] -> IO ()+staticRep _ [] = return ()+staticRep n [x]+ = do res <- staticEval n x+ case res of+ Left err -> putStrLn $ errString err+ Right (v, _) | v == _nil -> return ()+ Right (v, _) -> putStrLn (prStr v)+staticRep n (x : xs)+ = do res <- staticEval n x+ case res of+ Left err -> putStrLn $ errString err+ Right (_, n') -> staticRep n' xs++staticEval :: Int -> Either SwjError PVal -> IO (Either SwjError (Val, Int))+staticEval n (Right pval) = runExceptT (runStateT (runReaderT (doEval pval) initEnv) n)+staticEval _ (Left err) = return $ Left err++interactive :: IO ()+interactive = do hist <- readHistory+ void $ runStateT (loop 1) hist++teardown :: StateT (Seq String) IO ()+teardown = get >>= liftIO . writeHistory >> return ()++loop :: Int -> StateT (Seq String) IO ()+loop gsymCount+ = do input <- liftIO $ readline "swj> "+ case input of+ Nothing -> teardown+ Just str ->+ do newGsym <- feedLoop gsymCount (readAsts str)+ case newGsym of+ Nothing -> teardown+ Just val -> loop val++-- returns nothing if we pass in C-d+feedLoop :: Int -> ParseResult -> StateT (Seq String) IO (Maybe Int)+feedLoop gsymCount (Results rseq str)+ = do liftIO $ addHistory str+ modify (|> str)+ n' <- liftIO $ foldM rep gsymCount $ toList rseq+ return $ Just n'+feedLoop gsymCount (Continuation rseq accum cont)+ = do input <- liftIO $ readline "#_=> "+ case input of+ Nothing -> return Nothing+ Just str -> feedLoop gsymCount $ feedCont str rseq accum cont++rep :: Int -> Either SwjError PVal -> IO Int+rep n (Left err) = do putStrLn $ errString err+ return n+rep n (Right pval)+ = do res <- runExceptT (runStateT (runReaderT (doEval pval) initEnv) n)+ case res of+ Left err -> do putStrLn $ errString err+ return n+ Right (x, n') -> do putStrLn $ prStr x+ return n'++doEval :: PVal -> EvalState Val+doEval pval = readVal pval >>= eval++readHistory :: IO (Seq String)+readHistory = do hdir <- getAppDataDirectory "swearjure"+ createTree hdir+ let file = hdir </> fromText "history"+ isF <- isFile file+ if isF+ then do ls <- lines0 <$> readFile (encodeString file)+ mapM_ addHistory ls+ return $ fromList ls+ else return S.empty++writeHistory :: Seq String -> IO ()+writeHistory hist = do hdir <- getAppDataDirectory "swearjure"+ createTree hdir+ let fname = encodeString (hdir </> fromText "history")+ let hist' = takeLast 1000 hist+ writeFile fname (unlines0 $ toList hist')++-- | returns the last n elements in the seq as a seq, or the seq itself if it+-- contains less than n elements.+takeLast :: Int -> Seq a -> Seq a+takeLast n s = S.drop (S.length s - n) s++-- | like unlines, but separates with a null character. Removes the last line.+unlines0 :: [String] -> String+unlines0 = init . concatMap (++ "\0")++-- | line lines, but splits at null characters instead+lines0 :: String -> [String]+lines0 "" = []+lines0 s = cons (case break (== '\0') s of+ (l, s') -> (l, case s' of+ [] -> []+ _:s'' -> lines0 s''))+ where+ cons ~(h, t) = h : t
+ src/Swearjure/AST.hs view
@@ -0,0 +1,238 @@+{-# OPTIONS_GHC -Wall -Werror #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}++module Swearjure.AST where++import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Data.Generics.Fixplate+import qualified Data.Map as M+import Data.Ratio+import qualified Data.Set as S+import Swearjure.Errors+import System.Random (newStdGen)+import System.Random.Shuffle (shuffle')+import Text.PrettyPrint+++shuffle :: [a] -> EvalState [a]+shuffle [] = return []+shuffle xs = do rand <- liftIO newStdGen+ return $ shuffle' xs (length xs) rand++type EvalState = ReaderT Env (StateT Int (ExceptT SwjError IO))++type NS = String++data EnvF e = Toplevel (M.Map String (NS, (Bool, e)))+ | Nested (EnvF e) (M.Map String (NS, (Bool, e)))+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++type Env = EnvF Val++eqNs :: Maybe String -> String -> Bool+eqNs (Just x) y = x == y+eqNs Nothing _ = True++-- lookup and lookupMacro would've been namespaced if this was proper clojure,+-- but you can't refer to same-named values in different namespaces in+-- Swearjure, so it doesn't matter.+lookupMacro :: (MonadReader Env m) => (Maybe String) -> String -> m (Maybe Val)+lookupMacro ns s = ask >>= lookupRec+ where lookupRec (Toplevel m) = m `findOr` return Nothing+ lookupRec (Nested up m) = m `findOr` lookupRec up+ m `findOr` other+ = do let v = M.lookup s m+ case v of+ Just (_, (False, _)) -> return Nothing+ Just (ns', (True, macro)) | eqNs ns ns' -> return (Just macro)+ Just (_, (True, _)) -> other+ Nothing -> other++lookup :: (MonadReader Env m, MonadError SwjError m) =>+ (Maybe String) -> String -> m Val+lookup ns s = ask >>= lookupRec+ where lookupRec (Toplevel m) = m `findOr` throwError (NotFound s)+ lookupRec (Nested up m) = m `findOr` lookupRec up+ m `findOr` other+ = do let v = M.lookup s m+ case v of+ Just (ns', (False, val)) | eqNs ns ns' -> return val+ Just (ns', (True, _))+ | eqNs ns ns' -> throwError $ IllegalArgument $+ "Can't take value of macro: #'" ++ ns'+ ++ "/" ++ s+ _ -> other++extendEnv :: (MonadReader Env m) => Env -> [(String, Val)] -> m a -> m a+extendEnv oldEnv mappingList = local extend+ where extend _ = Nested oldEnv mapping+ mapping = M.fromList $ map (\(x, y) -> (x, ("user", (False, y))))+ mappingList++specials :: S.Set String+specials = S.fromList+ ["fn*", "quote", ".", "var", "&", "if", "nil"]++getMapping :: (MonadReader Env m) => String -> m (Maybe Val)+getMapping s = if S.member s specials+ then return . Just . Fix . ESym Nothing $ s+ else ask >>= lookupRec+ where lookupRec (Toplevel m) = m `findOr` return Nothing+ lookupRec (Nested up m) = m `findOr` lookupRec up+ m `findOr` other = do let v = M.lookup s m+ maybe other (namespaced . fst) v+ namespaced ns = return . Just . Fix . ESym (Just ns) $ s++data FnF e = Fn { fnEnv :: EnvF e+ , fnNs :: String+ , fnName :: String+ , fnRecName :: Maybe String+ , fnFns :: [([String], Maybe String, [e])]+ }+ | PrimFn (PFn Val)+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++data PFn e = Prim (String, String) ([e] -> EvalState e)++instance Eq (PFn e) where+ (Prim a _) == (Prim b _) = a == b++instance Ord (PFn e) where+ (Prim a _) `compare` (Prim b _) = a `compare` b++instance Show (PFn e) where+ show (Prim (ns, name) _) = "#<" ++ show ns ++ "$" ++ show name ++ ">"++type Fn = FnF Val++data SwjValF e = ESym (Maybe String) String+ | EStr String+ | EInt Integer+ | ERatio Rational+ | EFloat Double+ | EChar Char+ | EList [e]+ | EVec [e]+ | EHM [(e, e)]+ | ESet [e]+ | EKw (Maybe String) String+ | EBool Bool+ | EFn (FnF e)+ | EVar (FnF e) Bool+ | Nil+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++typeName' :: SwjValF e -> String+typeName' (ESym _ _) = "Symbol"+typeName' (EStr _ ) = "String"+typeName' (EInt _) = "Integer"+typeName' (ERatio _) = "Ratio"+typeName' (EFloat _) = "Float"+typeName' (EChar _) = "Char"+typeName' (EList _) = "PersistentList"+typeName' (EVec _) = "PersistentVector"+typeName' (EHM _) = "PersistentHashMap"+typeName' (ESet _) = "PersistentSet"+typeName' (EKw _ _) = "Keyword"+typeName' (EBool _) = "Boolean"+typeName' (EFn _) = "Fn"+typeName' (EVar _ _) = "Var"+typeName' Nil = "nil"++typeName :: Val -> String+typeName = typeName' . unFix++type Val = Mu SwjValF++iList :: [Val] -> Val+iList = Fix . EList++iVec :: [Val] -> Val+iVec = Fix . EVec++iHM :: [(Val, Val)] -> Val+iHM = Fix . EHM++iSet :: [Val] -> Val+iSet = Fix . ESet++instance EqF SwjValF where equalF = (==)+instance OrdF SwjValF where compareF = compare+instance ShowF SwjValF where showsPrecF = showsPrec++prStr :: Val -> String+prStr = show . pp' sfn+ where sfn str = char '"' <> text (unquote str) <> char '"'+ unquote = concatMap uq+ uq '\\' = "\\\\"+ uq '"' = "\\\""+ uq x = [x]++pp' :: (String -> Doc) -> Val -> Doc+pp' sfn = cata go+ where go (ESym ns s) = nsPP ns <> text s+ go (EStr s) = sfn s+ go (EInt n) = integer n+ go (ERatio r) = integer (numerator r) <> char '/' <> integer (denominator r)+ go (EFloat f) = double f+ go (EChar c) = char '\\' <> char c -- prettyprint-dependent+ go (EList xs) = parens $ hsep xs+ go (EVec xs) = brackets $ hsep xs+ go (EHM pairs) = braces $ hsep $ concatMap (\(x,y) -> [x, y]) pairs+ go (ESet s) = char '#' <> braces (hsep s)+ go (EKw ns s) = char ':' <> nsPP ns <> text s+ go (EBool True) = text "true"+ go (EBool False) = text "false"+ go (EFn Fn { fnNs = ns, fnName = fname})+ = text "#<" <> text ns <> char '$' <> text fname <> char '>'+ go (EFn (PrimFn (Prim (ns, fname) _)))+ = text "#<" <> text ns <> char '$' <> text fname <> char '>'+ go (EVar (Fn { fnNs = ns, fnName = fname}) _)+ = text "#'" <> text ns <> char '/' <> text fname+ go (EVar (PrimFn (Prim (ns, fname) _)) _)+ = text "#'" <> text ns <> char '/' <> text fname+ go Nil = text "nil"+ nsPP (Just ns) = text ns <> char '/'+ nsPP Nothing = empty++_quote :: Val+_quote = Fix $ ESym Nothing "quote"++_unquote :: Val+_unquote = Fix $ ESym (Just "clojure.core") "unquote"++_unquoteSplicing :: Val+_unquoteSplicing = Fix $ ESym (Just "clojure.core") "unquote-splicing"++_seq :: Val+_seq = Fix $ ESym (Just "clojure.core") "seq"++_concat :: Val+_concat = Fix $ ESym (Just "clojure.core") "concat"++_apply :: Val+_apply = Fix $ ESym (Just "clojure.core") "apply"++_list :: Val+_list = Fix $ ESym (Just "clojure.core") "list"++_vector :: Val+_vector = Fix $ ESym (Just "clojure.core") "vector"++_hashset :: Val+_hashset = Fix $ ESym (Just "clojure.core") "hash-set"++_hashmap :: Val+_hashmap = Fix $ ESym (Just "clojure.core") "hash-map"++_nil :: Val+_nil = Fix Nil++_fnStar :: Val+_fnStar = Fix $ ESym Nothing "fn*"++_var :: Val+_var = Fix $ ESym Nothing "var"
+ src/Swearjure/Errors.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -Wall -Werror #-}++module Swearjure.Errors where++data SwjError = SyntaxError String+ | IllegalState String+ | IllegalArgument String+ | ArityException Int String+ | CastException String String+ | NotFound String+ deriving (Show)++errString :: SwjError -> String+errString (SyntaxError err) = err+errString (IllegalState err) = "Illegal state: " ++ err+errString (IllegalArgument err) = "Illegal argument: " ++ err+errString (ArityException n fname) = "Wrong number of args (" ++ show n+ ++ ") passed to: " ++ fname+errString (CastException from to) = "Cast exception: " ++ from+ ++ " cannot be cast to " ++ to+errString (NotFound sym) = "Unable to resolve symbol: " ++ sym+ ++ " in this context"+
+ src/Swearjure/Eval.hs view
@@ -0,0 +1,269 @@+{-# OPTIONS_GHC -Wall -Werror #-}++module Swearjure.Eval where++import Control.Applicative ((<$>), (<*>))+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Data.Function (on)+import Data.Generics.Fixplate (Mu(..))+import Data.List (nub, sortBy)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, listToMaybe, isJust, isNothing)+import qualified Data.Set as S+import qualified Data.Traversable as T+import Prelude hiding (lookup, seq, concat)+import Swearjure.AST+import Swearjure.Errors+import Swearjure.Primitives++initEnv :: Env+initEnv = Toplevel $ M.fromList $ map+ (\(fname, f) -> (fname, ("clojure.core",+ (False, Fix $ EFn $ PrimFn+ (Prim ("core", fname) f)))))+ [ ("+", plus)+ , ("/", divFn)+ , ("*", mul)+ , ("-", minus)+ , ("list", return . Fix . EList)+ , ("vector", return . Fix . EVec)+ , ("apply", apply)+ , ("seq", liftM (Fix . EList) . seq)+ , ("concat", liftM (Fix . EList) . concat)+ , ("deref", deref)+ , ("hash-map", hashMap)+ , ("hash-set", hashSet)+ , ("<", lt)+ , (">", gt)+ , ("<=", lte)+ , (">=", gte)+ , ("=", eq)+ , ("==", numEq)+ ] ++ map+ (\(fname, f) -> (fname, ("clojure.core",+ (True, Fix $ EFn $ PrimFn+ (Prim ("core", fname) f)))))+ -- TODO: Implement these as non-prim macros in Swearjure. Somehow.+ [ ("->>", threadLast)+ , ("->", threadSnd)+ ]+ ++ map+ (\(fname, f) -> (fname, ("swearjure.core",+ (False, Fix $ EFn $ PrimFn+ (Prim ("swearjure.core", fname) f)))))+ [ ("<<'", readChar)+ , (">>'", prChars)+ , (">>", prn)+ ]++apply :: [Val] -> EvalState Val+apply [] = throwError $ ArityException 0 "core/apply"+apply [_] = throwError $ ArityException 1 "core/apply"+apply (f : xs) = do fn <- ifn f+ lastOnes <- seq [last xs]+ let spliced = init xs ++ lastOnes+ runFn fn spliced++runFn :: Fn -> [Val]-> EvalState Val+runFn f@Fn {fnEnv = env, fnRecName = fname+ , fnFns = options} args+ = do (paramNames, restName, exprs) <- findOption (length args) options+ mapping <- prepMapping paramNames restName args $ recBinding fname+ thunk <- extendEnv env mapping (evalAll exprs)+ thunk+ where findOption n [] = throwError $ ArityException n (prStr $ Fix $ EFn f)+ findOption n (opt : rst)+ | argcPred opt n = return opt+ | otherwise = findOption n rst+ argcPred (params, Just _, _) = (length params <=)+ argcPred (params, Nothing, _) = (length params ==)+ recBinding (Just x) = [(x, Fix $ EFn f)]+ recBinding Nothing = []+ prepMapping (p : ps) r (x : xs) acc = prepMapping ps r xs $ (p, x) : acc+ prepMapping [] (Just r) xs acc = return $ (r, Fix $ EList xs) : acc+ prepMapping [] Nothing [] acc = return acc+ prepMapping _ _ _ _ = throwError $ IllegalState $ "Well, we still have"+ ++ " some arguments left, but no values to assign"+ -- Returns a thunk, in order to support tail recursion+ evalAll [x@(Fix (EList []))] = return $ return x+ evalAll [Fix (EList xs)]+ | head xs == _quote = return $ return $ fromMaybe _nil (listToMaybe $ tail xs)+ | head xs == _var = return $ var (tail xs)+ | head xs == _nil = throwError $ IllegalArgument "Can't call nil"+ -- need to trick the thunkification here: We must run this in the+ -- parent environment, so let's just grab it and rewrap the result.+ | head xs == _fnStar = do env' <- ask+ return $ local (const env')+ (makeLambda $ tail xs)+ | otherwise = do evf : evxs <- mapM eval xs+ return $ apply [evf, Fix (EList evxs)]+ evalAll [x] = return $ return x+ evalAll (x : xs) = eval x >> evalAll xs+ evalAll [] = return $ return _nil+runFn (PrimFn (Prim _ prim)) args = prim args++macroexpand :: Val -> EvalState Val+macroexpand lst@(Fix (EList (x@(Fix (ESym ns s)) : xs)))+ | x == _quote = return lst+ | x == _fnStar = return lst+ | x == _var = return lst+ | otherwise = do maybeMacro <- lookupMacro ns s+ case maybeMacro of+ Just macro ->+ do expandOnce <- apply [macro, Fix (EList xs)]+ macroexpand expandOnce+ Nothing -> Fix <$> T.mapM macroexpand (unFix lst)+macroexpand (Fix x) = Fix <$> T.mapM macroexpand x++eval :: Val -> EvalState Val+eval = macroexpand >=> go . unFix+ where go (ESym ns s) = lookup ns s+ go x@(EList []) = return $ Fix x+ go (EList xs)+ | head xs == _quote = return $ fromMaybe _nil (listToMaybe $ tail xs)+ | head xs == _var = var (tail xs)+ | head xs == _nil = throwError $ IllegalArgument "Can't call nil"+ | head xs == _fnStar = makeLambda $ tail xs+ | otherwise = do f : xs' <- mapM eval xs+ apply [f, Fix (EList xs')]+ go v@(EVec _) = Fix <$> T.mapM eval v+ go (ESet xs) = do evals <- mapM eval xs+ checkDupe evals+ return $ Fix $ ESet evals+ go (EHM pairs) = do evals <- mapMtuple eval pairs+ checkDupe $ map fst evals+ return $ Fix $ EHM evals+ go x = return $ Fix x+ mapMtuple f = mapM (\(x,y) -> (,) <$> f x <*> f y)++-- from GHC.Exts++-- | The 'sortWith' function sorts a list of elements using the+-- user supplied function to project something out of each element+sortWith :: Ord b => (a -> b) -> [a] -> [a]+sortWith f = sortBy (compare `on` f)++makeLambda :: [Val] -> EvalState Val+makeLambda xs = do env <- ask+ num <- get+ modify (+2)+ (recName, rst) <- findName $ map unFix xs+ fns <- sortWith (\(x, y, _) -> length x + countMaybe y)+ <$> mkUnsureFn rst+ validateArity $ map (\(x, y, _) -> (length x, y)) fns+ -- TODO: Walk the values and verify that symbols and vars can+ -- be resolved.+ return $ Fix $ EFn+ Fn { fnEnv = env+ , fnNs = "user"+ , fnName = mungedName recName num+ , fnRecName = recName+ , fnFns = fns+ }+ where mungedName (Just fname) num = "eval" ++ show num ++ "$" ++ fname ++ "__"+ ++ show (num + 1)+ mungedName Nothing num = mungedName (Just "fn") num+ findName (ESym _ s : rst)+ | S.member s specials = throwError $ IllegalArgument+ $ "Can't use " ++ s ++ " as function name"+ | otherwise = return (Just s, rst)+ findName r = return (Nothing, r)+ mkUnsureFn :: [SwjValF Val] -> EvalState [([String], Maybe String, [Val])]+ mkUnsureFn [] = return []+ mkUnsureFn lst@(EList _ : _) = mkFns lst+ mkUnsureFn lst@(EVec _ : _) = do fn <- mkFn lst+ return [fn]+ mkUnsureFn (x : _) = throwError $ CastException (typeName' x) "List/Vector"+ mkFn (EVec args' : exprs)+ = do (args, restArg) <- validateArgs $ map unFix args'+ return (args, restArg, map Fix exprs)+ mkFn (x : _) = throwError $ CastException (typeName' x) "Vector"+ mkFn [] = throwError $ IllegalArgument+ "(This gives a NullPointerException in Clojure)"+ mkFns = mapM (mkFn <=< unList)+ unList (EList ys) = return $ map unFix ys+ unList x = throwError $ CastException (typeName' x) "List"+ validateArgs [] = return ([], Nothing)+ validateArgs (s@(ESym (Just _) _) : _)+ = throwError $ IllegalArgument $+ "Can't use qualified name as parameter: " ++ prStr (Fix s)+ validateArgs [ESym Nothing "&", s@(ESym (Just _) _)]+ = throwError $ IllegalArgument $+ "Can't use qualified name as parameter: " ++ prStr (Fix s)+ validateArgs [ESym Nothing "&", ESym Nothing s]+ | s /= "&" = return ([], Just s)+ | otherwise = throwError $ IllegalArgument "Invalid parameter list"+ validateArgs (ESym Nothing s : args')+ | s /= "&" = do (args, restArg) <- validateArgs args'+ return (s : args, restArg)+ | otherwise = throwError $ IllegalArgument "Invalid parameter list"+ validateArgs (x : _) = throwError $ IllegalArgument+ $ "Unsupported binding key: " ++ prStr (Fix x)+ -- assumes these are sorted by size+ validateArity ys+ = do when (1 < variadicCount ys) $+ throwError $ IllegalArgument+ "Can't have more than 1 variadic overload"+ when (ys /= nub ys) $ throwError $ IllegalArgument+ "Can't have 2 overloads with same arity"+ when (variadicCount ys == 1 &&+ isNothing (snd $ last ys)) $+ throwError $ IllegalArgument $ "Can't have fixed arity "+ ++ "function with more params than variadic function"+ variadicCount ys = length (filter isJust (map snd ys))+ countMaybe Nothing = 0+ countMaybe (Just _) = 1++ifn :: Val -> EvalState Fn+ifn = go . unFix+ where go :: SwjValF Val -> EvalState Fn+ go s@(ESym _ _) = lookupThing s+ go kw@(EKw _ _) = lookupThing kw+ go (EFn f) = return f+ go v@(EVec _) = lookup1 v+ go s@(ESet _) = lookup1 s+ go hm@(EHM _) = lookup12 hm+ -- TODO: When dereffed, this prints badly.+ go (EVar f True) = unnamedPrim -- this always throws arity exceptions+ (\x -> throwError $ ArityException (length x)+ (prStr $ Fix $ EFn f)) -- TODO: Not printed correctly.+ go (EVar fn False) = return fn+ go x = throwError $ CastException (typeName' x) "IFn"+ lookupThing s = unnamedPrim+ (\xs -> let (f, r) = splitAt 1 xs in+ getFn $ f ++ [Fix s] ++ r)+ lookup12 hm = unnamedPrim $ getFn . (Fix hm :)+ lookup1 x = unnamedPrim $ get1Fn . (Fix x :)+ unnamedPrim = return . PrimFn . Prim ("", "")++-- I'd usually put this in prims, but deref needs to convert val through ifn+deref :: [Val] -> EvalState Val+deref [f@(Fix (EVar _ _))] = Fix . EFn <$> (ifn f)+deref [x] = throwError $ CastException (typeName x) "java.util.concurrent.Future"+deref x = throwError $ ArityException (length x) "core/deref"+++checkDupe :: [Val] -> EvalState ()+checkDupe = go S.empty+ where go _ [] = return ()+ go s (x : r)+ | S.member x s = throwError $ IllegalState+ $ "Duplicate entry: " ++ prStr x+ | otherwise = go (S.insert x s) r++var :: [Val] -> EvalState Val+var (Fix (ESym ns v) : _)+ = do macroLookup <- lookupMacro ns v+ case macroLookup of+ (Just (Fix (EFn mac))) -> return $ Fix (EVar mac True)+ (Just _) -> throwError $ IllegalState $ "Internal Swearjure error --" +++ " macro lookup returned non-macro function"+ Nothing -> do valLookup <- lookup ns v+ case valLookup of+ (Fix (EFn fn)) -> return $ Fix (EVar fn False)+ _ -> throwError $ IllegalState $ "Swearjure can't take var of non-fn value"+var (v : _) = throwError $ CastException (typeName v) "Symbol"+var [] = throwError $ IllegalArgument+ "(This gives a NullPointerException in Clojure)"
+ src/Swearjure/Parser.hs view
@@ -0,0 +1,256 @@+{-# OPTIONS_GHC -Wall -Werror #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}++module Swearjure.Parser+ ( PValF(..)+ , PVal+ , readAsts+ , readStatic+ , ParseResult(..)+ , feedCont+ ) where++import Control.Applicative hiding (many)+import Control.Monad.Reader+import Data.Attoparsec.Text+import qualified Data.Attoparsec.Text.Lazy as L+import Data.Char (isAlphaNum)+import Data.Foldable (Foldable)+import Data.Generics.Fixplate (Mu(..), ShowF(..), EqF(..), OrdF(..))+import Data.Sequence+import qualified Data.Sequence as S+import qualified Data.Text as T+import qualified Data.Text.Lazy as B+import Data.Traversable (Traversable)+import Swearjure.Errors++type ParseState = Bool++data PValF p = PSym String+ | PString String+ | PKw String+ | PQualKw String+ | PChar Char+ | PFnLit [p]+ | PList [p]+ | PVec [p]+ | PSet [p]+ | PHM [(p, p)]+ | PSyntaxQuote p+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++type PVal = Mu PValF++instance EqF PValF where equalF = (==)+instance OrdF PValF where compareF = compare+instance ShowF PValF where showsPrecF = showsPrec++cljns :: String+cljns = "clojure.core/"++-- | Discards the result of the parser+omit :: Parser p -> Parser ()+omit p = p >> return ()++-- | Semi matches a semicolon and returns it+semi :: Parser Char+semi = char ';'++commentLine :: Parser String+commentLine = skipMany1 semi >> manyTill anyChar (endOfLine <|> endOfInput)++-- | Filters out any kind of whitespace.+whiteSpace :: ParseState -> Parser ()+whiteSpace b = skipMany (omit (char ',') <|> omit space <|> omit commentLine+ <|> try (sharpWhites b))++sharpWhites :: ParseState -> Parser ()+sharpWhites b = char '#' >> (sharp_ b <|> sharpBang)++sharp_ :: ParseState -> Parser ()+sharp_ b = char '_' >> omit (expr b)++sharpBang :: Parser ()+sharpBang = char '!' >> manyTill anyChar (endOfLine <|> endOfInput) >> return ()++lexeme :: Parser p -> ParseState -> Parser p+lexeme p b = whiteSpace b >> p++anyOf :: String -> Parser Char+anyOf = satisfy . inClass++-- fixme: These are.. nasty to do properly.+startSymChar :: Parser Char+startSymChar = anyOf "-+*/!=<>?_&$%"++symChar :: Parser Char+symChar = startSymChar <|> anyOf "#'"++-- TODO: If sym only contains single /, then / can't be the last value UNLESS+-- the symbol is "/".+symString :: Parser String+symString = do x <- startSymChar+ xs <- many' symChar+ return $ x : xs++symbol :: Parser PVal+symbol = (Fix . PSym) <$> symString++keyword :: Parser PVal+keyword = char ':' >> (nonQual <|> qual <|> alphaNums)+ where nonQual = Fix . PKw <$> symString+ qual = Fix . PQualKw <$> (char ':' >> symString)++between :: Parser open -> Parser close -> Parser a -> Parser a+between open close p = do { omit open; v <- p; omit close; return v }++swjString :: Parser PVal+swjString = Fix . PString <$> (between (char '"') (char '"')+ (many' stringChar))+ where stringChar = stringLetter <|> stringEscape+ <?> "string character (non-alphanumeric)"+ stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && not (isAlphaNum c))+ -- Todo: Fix this properly?+ stringEscape = char '\\' >> anyOf "\\\""++delimited :: Char -> Char -> Parser c -> ParseState -> Parser c+delimited start stop p b = between (char start) (lexeme (char stop) b) p++list :: ParseState -> Parser PVal+list b = Fix . PList <$> delimited '(' ')' (many' $ expr b) b++vec :: ParseState -> Parser PVal+vec b = Fix . PVec <$> delimited '[' ']' (many' $ expr b) b++hashMap :: ParseState -> Parser PVal+hashMap b = Fix . PHM <$> delimited '{' '}' (many' pair) b+ where pair = (,) <$> expr b <*> expr b++call :: String -> [PVal] -> PVal+call s es = Fix . PList $ (Fix . PSym) s : es++sugared :: Char -> String -> ParseState -> Parser PVal+sugared c s b = do omit (char c)+ e <- expr b+ return $ call (cljns ++ s) [e]++quote :: ParseState -> Parser PVal+quote b = do omit (char '\'')+ e <- expr b+ return $ call "quote" [e]++syntaxQuote :: ParseState -> Parser PVal+syntaxQuote b = char '`' >> (Fix . PSyntaxQuote <$> expr b)++deref :: ParseState -> Parser PVal+deref = sugared '@' "deref"++optionMaybe :: Parser p -> Parser (Maybe p)+optionMaybe p = option Nothing (liftM Just p)++-- this needs a bit of help to avoid turning ~@foo into (unquote (deref foo))+unquote :: ParseState -> Parser PVal+unquote b = do omit $ char '~'+ splice <- optionMaybe $ char '@'+ e <- expr b+ return $ call (unquoteType splice) [e]+ where unquoteType (Just _) = cljns ++ "unquote-splicing"+ unquoteType Nothing = cljns ++ "unquote"++-- TODO: Should use attr to tag on vals.+--meta :: Parser PVal+--meta = do omit $ char '^'+-- m <- expr+-- e <- expr+-- return $ call "with-meta" [e, m]++-- sharpies be here++sharp :: ParseState -> Parser PVal+sharp b = char '#' >> (sharpQuote b <|> set b <|> fnLit b <|> unreadable)++sharpQuote :: ParseState -> Parser PVal+sharpQuote b = do omit (char '\'')+ e <- expr b+ return $ call "var" [e]++-- must propagate the Bool over the affected results+fnLit :: ParseState -> Parser PVal+fnLit True = fail "Nested #() are not allowed"+fnLit False = do omit $ char '('+ exps <- many' (expr True)+ omit $ char ')'+ return $ Fix $ PFnLit exps++set :: ParseState -> Parser PVal+set b = Fix . PSet <$> delimited '{' '}' (many' $ expr b) b++unreadable :: Parser a+unreadable = char '<' >> fail "Unreadable form"++-- TODO: #=+-- TODO: #@? and #?++character :: Parser PVal+character = char '\\' >> (Fix . PChar <$> satisfy (not . isAlphaNum))++alphaNums :: Parser a+alphaNums = satisfy isAlphaNum >> fail "Alphanumeric characters are not allowed"++expr :: Bool -> Parser PVal+expr b+ = do whiteSpace b+ list b <|> vec b <|> symbol <|> keyword <|> swjString <|> hashMap b+ <|> quote b <|> syntaxQuote b <|> deref b <|> unquote b <|> sharp b <|>+ character <|> alphaNums++justWS :: String -> Bool+justWS s+ = case parse (whiteSpace False) (T.pack s) of+ (Fail _ _ _) -> False+ (Partial _) -> True+ (Done txt ()) -> T.null txt++type ResultSeq = (Seq (Either SwjError PVal))+type ParseFn = T.Text -> Result PVal++-- parsing != "reading". A PVal is expanded because of reader conditionals+data ParseResult = Results ResultSeq String+ | Continuation ResultSeq String ParseFn++-- feeds Continuations more data. The continuation must be unwrapped+feedCont :: String -> ResultSeq -> String -> ParseFn -> ParseResult+feedCont s xs accum cont+ = merge $ readRec (cont $ T.pack $ s ++ "\n")+ where merge (vals, Nothing) = Results (xs >< vals) (accum ++ ('\n' : s))+ merge (vals, Just newCont) = Continuation (xs >< vals)+ (accum ++ ('\n' : s)) newCont++readRec :: Result PVal -> (ResultSeq, Maybe ParseFn)+readRec (Fail _ _ err) = (S.singleton $ Left $ SyntaxError err, Nothing)+readRec (Partial cont) = (S.empty, Just cont)+readRec (Done txt r) | justWS (T.unpack txt) = (S.singleton $ Right r, Nothing)+readRec (Done txt r) = recur deeper+ where deeper = readRec $ parse (whiteSpace False >> expr False) txt+ recur (x, y) = (Right r <| x, y)++readAsts :: String -> ParseResult+readAsts s | justWS s = Results S.empty s+readAsts s = foo $ readRec $ parse (whiteSpace False >> expr False) (T.pack $ s ++ "\n")+ where foo (vals, Nothing) = Results vals s+ foo (vals, Just cont) = Continuation vals s cont++-- difference between readStatic and readAsts is that readStatic is incremental,+-- and won't give back continuations. Consequently it just gobbles until it's+-- done. Passes back a list to avoid the strictness we get with Sequences.+readStatic :: B.Text -> [Either SwjError PVal]+readStatic s | lazyWS s = []+readStatic s = go $ L.parse (whiteSpace False >> expr False) s+ where go (L.Fail _ _ err) = [Left $ SyntaxError err]+ go (L.Done txt r) = Right r : readStatic txt++lazyWS :: B.Text -> Bool+lazyWS s = case L.parse (whiteSpace False) s of+ (L.Fail _ _ _) -> False+ (L.Done txt ()) -> B.null txt
+ src/Swearjure/Primitives.hs view
@@ -0,0 +1,248 @@+{-# OPTIONS_GHC -Wall -Werror #-}+{-# LANGUAGE RankNTypes #-}++module Swearjure.Primitives where++import Control.Applicative ((<$>))+import Control.Monad.Except+import Data.Char (chr, ord)+import Data.Generics.Fixplate+import qualified Data.Map as M+import Data.Ratio+import qualified Data.Set as S+import Prelude hiding (seq)+import Swearjure.AST hiding (lookup)+import Swearjure.Errors+import System.IO++getFn :: [Val] -> EvalState Val+getFn [m, v] = getFn [m, v, Fix Nil]+getFn [m, k, default'] = find (unFix m) k default'+ where find (ESet vals) v d+ | v `elem` vals = return v+ | otherwise = return d+ find (EVec vals) (Fix (EInt n)) d+ | n < 0 = return d+ | length vals > fromIntegral n = return $ vals !! fromIntegral n+ | otherwise = return d+ find (EVec _) _ d = return d+ find (EHM pairs) v d = case lookup v pairs of+ Just res -> return res+ Nothing -> return d+ find _ _ d = return d+getFn x = throwError $ ArityException (length x) "core/get"++get1Fn :: [Val] -> EvalState Val+get1Fn [m, k] = go (unFix m)+ where go (EVec vals)+ = case unFix k of+ EInt n | n < 0 -> throwError $ IllegalArgument "Index can't be negative"+ EInt n | length vals > fromIntegral n -> return $ vals !! fromIntegral n+ EInt _ -> throwError $ IllegalArgument "Index out of bounds for vector"+ _ -> throwError $ IllegalArgument "Key must be integer"+ go (ESet vals)+ = if k `elem` vals+ then return k+ else return $ Fix Nil+ go _ = throwError $ IllegalState "Internal Swearjure error -- get1Fn got unexpected value"+get1Fn xs = throwError $ ArityException (length xs) (typeName $ head xs)++-- this one must be wrapped properly to use in envs. (liftM (Fix . EList) . seq)+seq :: [Val] -> EvalState [Val]+seq [x] = go (unFix x)+ where go (ESet vals) = return vals+ go (EList vals) = return vals+ go (EVec vals) = return vals+ go (EHM pairs) = return $ vecPairs pairs+ go (EStr s) = return $ map (Fix . EChar) s+ go Nil = return []+ go x' = throwError $ CastException (typeName' x') "ISeq"+ vecPairs = map (\(a, b) -> (Fix (EVec [a, b])))+seq x = throwError $ ArityException (length x) "core/seq"++-- same as above+concat :: [Val] -> EvalState [Val]+concat xs = foldM prepend [] (reverse xs)+ where prepend acc v = do s <- seq [v]+ return $ s ++ acc++multiCmp :: (SwjValF Val -> SwjValF Val -> EvalState Bool) -> String+ -> [SwjValF Val] -> EvalState Val+multiCmp _ fname [] = throwError $ ArityException 0 fname+multiCmp _ _ [_] = return $ Fix $ EBool True+multiCmp f _ [x, y] = liftM (Fix . EBool) $ f x y+multiCmp f fname (a : b : r) = do res <- f a b+ if res+ then multiCmp f fname (b : r)+ else return $ Fix $ EBool False++numOp :: (forall a. Ord a => a -> a -> Bool) -> SwjValF Val -> SwjValF Val+ -> EvalState Bool+numOp op = cmp+ where cmp (EInt x) (EInt y) = return $ x `op` y+ cmp (EInt x) (EFloat y) = return $ fromIntegral x `op` y+ cmp (EInt x) (ERatio y) = return $ (x % 1) `op` y+ cmp (EFloat x) (EInt y) = return $ x `op` fromIntegral y+ cmp (EFloat x) (EFloat y) = return $ x `op` y+ cmp (EFloat x) (ERatio y) = return $ x `op` asFloat y+ cmp (ERatio x) (ERatio y) = return $ x `op` y+ cmp (ERatio x) (EInt y) = return $ x `op` (y % 1)+ cmp (ERatio x) (EFloat y) = return $ asFloat x `op` y+ cmp x y+ | isNum x = throwError $ CastException (typeName' y) "Number"+ | otherwise = throwError $ CastException (typeName' x) "Number"++lt :: [Val] -> EvalState Val+lt = multiCmp (numOp (<)) "core/<" . map unFix++lte :: [Val] -> EvalState Val+lte = multiCmp (numOp (<=)) "core/<=" . map unFix++gt :: [Val] -> EvalState Val+gt = multiCmp (numOp (>)) "core/>" . map unFix++gte :: [Val] -> EvalState Val+gte = multiCmp (numOp (>=)) "core/>=" . map unFix++numEq :: [Val] -> EvalState Val+numEq = multiCmp (numOp (==)) "core/==" . map unFix++eq :: [Val] -> EvalState Val+eq [] = throwError $ ArityException 0 "core/="+eq [_] = return $ Fix $ EBool True+eq (x : y : r) = if x == y+ then eq (y : r)+ else return $ Fix $ EBool False++-- hash-map and hash-set++hashMap :: [Val] -> EvalState Val+hashMap xs = Fix . EHM <$> (go M.empty xs >>= shuffle . M.toList)+ where go m [] = return m+ go _ [k] = throwError $ IllegalArgument $ "No value supplied for key: " ++ prStr k+ go m (k : v : kvs) = go (M.insert k v m) kvs++hashSet :: [Val] -> EvalState Val+hashSet xs = Fix . ESet <$> (go S.empty xs >>= shuffle . S.toList)+ where go s [] = return s+ go s (v : vs) = go (S.insert v s) vs++-- ->> and ->++threadLast :: [Val] -> EvalState Val+threadLast [] = throwError $ ArityException 0 "core/->>"+threadLast [x] = return x+threadLast (x : Fix (EList ys) : r) = threadLast $ iList (ys ++ [x]) : r+threadLast (x : y : r) = threadLast $ iList [y, x] : r++threadSnd :: [Val] -> EvalState Val+threadSnd [] = throwError $ ArityException 0 "core/->"+threadSnd [x] = return x+threadSnd (x : Fix (EList ys) : r)+ = let (yfst, ysnd) = splitAt 1 ys in+ threadSnd $ iList (yfst ++ [x] ++ ysnd) : r+threadSnd (x : y : r) = threadSnd $ iList [y, x] : r++-- I see that these operations can be generalized, but it won't make them easier+-- to maintain or anything, really.++plus :: [Val] -> EvalState Val+plus xs = Fix <$> foldM (|+|) (EInt 0) (map unFix xs)+ where (EInt x) |+| (EInt y) = return $ EInt (x + y)+ (EInt x) |+| (EFloat y) = return $ EFloat (fromIntegral x + y)+ (EInt x) |+| (ERatio rat) = unRatio ((x % 1) + rat)+ (EFloat x) |+| (EInt y) = return $ EFloat (x + fromIntegral y)+ (EFloat x) |+| (EFloat y) = return $ EFloat (x + y)+ (EFloat x) |+| (ERatio rat) = return $ EFloat (x + asFloat rat)+ (ERatio rat) |+| (EInt y) = unRatio (rat + (y % 1))+ (ERatio rat) |+| (EFloat y) = return $ EFloat (asFloat rat + y)+ (ERatio x) |+| (ERatio y) = unRatio (x + y)+ x |+| y+ | isNum x = throwError $ CastException (typeName' y) "Number"+ | otherwise = throwError $ CastException (typeName' x) "Number"++minus :: [Val] -> EvalState Val+minus [] = throwError $ ArityException 0 "core/-"+minus [x] = minus [Fix (EInt 0), x]+minus (x' : xs) = Fix <$> foldM (|-|) (unFix x') (map unFix xs)+ where (EInt x) |-| (EInt y) = return $ EInt (x - y)+ (EInt x) |-| (EFloat y) = return $ EFloat (fromIntegral x - y)+ (EInt x) |-| (ERatio rat) = unRatio ((x % 1) - rat)+ (EFloat x) |-| (EInt y) = return $ EFloat (x - fromIntegral y)+ (EFloat x) |-| (EFloat y) = return $ EFloat (x - y)+ (EFloat x) |-| (ERatio rat) = return $ EFloat (x - asFloat rat)+ (ERatio rat) |-| (EInt y) = unRatio (rat - (y % 1))+ (ERatio rat) |-| (EFloat y) = return $ EFloat (asFloat rat - y)+ (ERatio x) |-| (ERatio y) = unRatio (x - y)+ x |-| y+ | isNum x = throwError $ CastException (typeName' y) "Number"+ | otherwise = throwError $ CastException (typeName' x) "Number"++mul :: [Val] -> EvalState Val+mul xs = Fix <$> foldM (|*|) (EInt 1) (map unFix xs)+ where (EInt x) |*| (EInt y) = return $ EInt (x * y)+ (EInt x) |*| (EFloat y) = return $ EFloat (fromIntegral x * y)+ (EInt y) |*| (ERatio rat) = unRatio ((y % 1) * rat)+ (EFloat x) |*| (EInt y) = return $ EFloat (x * fromIntegral y)+ (EFloat x) |*| (EFloat y) = return $ EFloat (x * y)+ (EFloat x) |*| (ERatio rat) = return $ EFloat (x * asFloat rat)+ (ERatio rat) |*| (EInt y) = unRatio (rat * (y % 1))+ (ERatio rat) |*| (EFloat y) = return $ EFloat (asFloat rat * y)+ (ERatio x) |*| (ERatio y) = unRatio (x * y)+ x |*| y+ | isNum x = throwError $ CastException (typeName' y) "Number"+ | otherwise = throwError $ CastException (typeName' x) "Number"++divFn :: [Val] -> EvalState Val+divFn [] = throwError $ ArityException 0 "core//"+divFn [x] = divFn [Fix (EInt 1), x]+divFn (x' : xs) = Fix <$> foldM divide (unFix x') (map unFix xs)+ where (EInt n) `divide` (EInt val) = safeRat n val+ (EInt x) `divide` (ERatio y) = unRatio $ (x % 1) / y+ (EInt x) `divide` (EFloat y) = return $ EFloat (fromIntegral x / y)+ (EFloat x) `divide` (EInt y) = return $ EFloat (x / fromIntegral y)+ (EFloat x) `divide` (EFloat y) = return $ EFloat (x / y)+ (EFloat x) `divide` (ERatio rat) = EFloat x `divide` EFloat (asFloat rat)+ (ERatio _) `divide` (EInt 0) = throwError $ IllegalArgument "Cannot divide by 0"+ (ERatio rat) `divide` (EInt y) = unRatio (rat / (y % 1))+ (ERatio rat) `divide` (EFloat y) = EFloat (asFloat rat) `divide` EFloat y+ (ERatio x) `divide `(ERatio y) = unRatio (x / y)+ x `divide` y+ | isNum x = throwError $ CastException (typeName' y) "Number"+ | otherwise = throwError $ CastException (typeName' x) "Number"++prChars :: [Val] -> EvalState Val+prChars [] = return $ Fix Nil+prChars (Fix (EInt n) : xs) = do liftIO $ putChar (chr $ fromIntegral n)+ liftIO $ hFlush stdout+ prChars xs+prChars (x : _) = throwError $ CastException (typeName x) "Integer"++readChar :: [a] -> EvalState Val+readChar [] = do n <- ord <$> liftIO getChar+ return $ Fix $ EInt (toInteger n)+readChar xs = throwError $ ArityException (length xs) "swearjure.core/<<'"++prn :: [Val] -> EvalState Val+prn xs = do let printString = unwords $ map prStr xs+ liftIO $ putStrLn printString+ return $ Fix Nil++safeRat :: Integer -> Integer -> EvalState (SwjValF e)+safeRat num den = case den of+ 0 -> throwError $ IllegalArgument "Cannot divide by 0"+ _ -> unRatio (num % den)++unRatio :: Rational -> EvalState (SwjValF e)+unRatio rat = return (case denominator rat of+ 1 -> EInt $ numerator rat+ _ -> ERatio rat)++asFloat :: Rational -> Double+asFloat rat = fromIntegral (numerator rat) / fromIntegral (denominator rat)++isNum :: SwjValF e -> Bool+isNum (EInt _) = True+isNum (EFloat _) = True+isNum (ERatio _) = True+isNum _ = False
+ src/Swearjure/Reader.hs view
@@ -0,0 +1,158 @@+{-# OPTIONS_GHC -Wall -Werror #-}++module Swearjure.Reader where++import Control.Applicative ((<$>), (<*>))+import Control.Monad.Except+import Control.Monad.State+import qualified Data.Generics.Fixplate as F+import Data.Generics.Fixplate hiding (mapM)+import Data.List (elemIndex)+import qualified Data.Map as M+import Data.Maybe (maybeToList, fromMaybe, isJust)+import Prelude hiding (seq)+import Swearjure.AST+import Swearjure.Errors+import Swearjure.Parser++readVal :: PVal -> EvalState Val+readVal ast = replaceFnLits ast >>= convertAst++convertAst :: PVal -> EvalState Val+convertAst = go+ where go :: PVal -> EvalState Val+ go = liftM Fix . goF . unFix+ goF :: PValF PVal -> EvalState (SwjValF Val)+ goF (PSym s) = return $ uncurry ESym $ splitSym s+ goF (PString s) = return $ EStr s+ goF (PKw s) = return $ uncurry EKw $ splitSym s+ goF (PQualKw s) = return $ EKw (Just "user") s+ -- -^ if we could move nses, this would've forced this fn to be of+ -- EvalState+ goF (PChar c) = return $ EChar c+ -- TODO: Go over to compdata. Excellent fit here actually, as this+ -- traversal is over a desugared ast.+ goF (PFnLit _) = throwError $ IllegalState $ "Internal error: Function "+ ++ "literals should've been eradicated by now"+ goF (PList xs) = EList <$> mapM go xs+ goF (PVec xs) = EVec <$> mapM go xs+ -- randomization of sets and hash maps+ goF (PSet xs) = do vals <- mapM go xs+ ESet <$> shuffle vals+ -- want this to be Data.Set, but forces eq + ord on Mu/Attr+ goF (PHM pairs) = do vals <- mapM (\(x, y) -> (,) <$> go x <*> go y) pairs+ EHM <$> shuffle vals+ goF (PSyntaxQuote x) = syntaxUnquote x >>= goF++splitSym :: String -> (Maybe String, String)+splitSym "/" = (Nothing, "/")+splitSym s = case '/' `elemIndex` s of+ Nothing -> (Nothing, s)+ Just idx -> let (ns, name) = splitAt idx s in+ (Just ns, tail name)++replaceFnLits :: PVal -> EvalState PVal+replaceFnLits (Fix (PFnLit xs'))+ = do xs <- replacePercents xs'+ return $ Fix $ PList $ (Fix $ PSym "fn*") : xs+replaceFnLits (Fix x) = Fix <$> F.mapM replaceFnLits x++replacePercents :: [PVal] -> EvalState [PVal]+replacePercents e = prepareArglist <$> runStateT (mapM (cataM go) e)+ (Nothing, Nothing)+ where go (PSym "%")+ = do (p1, r) <- get+ case p1 of+ Nothing -> do cnt <- lift get+ lift $ modify succ+ let p1s = p1sym cnt+ put (Just p1s, r)+ return p1s+ (Just p1s) -> return p1s+ go (PSym "%&")+ = do (p1, r) <- get+ case r of+ Nothing -> do cnt <- lift get+ lift $ modify succ+ let rsym = restSym cnt+ put (p1, Just rsym)+ return rsym+ (Just rsym) -> return rsym+ go x = return $ Fix x+ p1sym cnt = Fix $ PSym $ "p1__" ++ show cnt ++ "#"+ restSym cnt = Fix $ PSym $ "rest__" ++ show cnt ++ "#"+ prepareArglist (es, (p1, rest))+ = let arglist = maybeToList p1 ++ restArglist rest in+ [ (Fix . PVec) arglist+ , (Fix . PList) es]+ restArglist (Just rest) = [Fix $ PSym "&", rest]+ restArglist Nothing = []++syntaxUnquote :: PVal -> EvalState (PValF PVal)+syntaxUnquote e = fst <$> runStateT (go $ unFix e) M.empty+ where go :: PValF PVal -> StateT (M.Map String (PValF PVal)) EvalState (PValF PVal)+ go sym@(PSym s)+ | last s == '#'+ = do r <- gets (M.lookup s)+ case r of+ Just replacement -> return replacement+ Nothing ->+ do symCnt <- lift get+ lift $ modify succ+ let gsym = PList [_pquote, gensym s symCnt]+ modify $ M.insert s gsym+ return gsym+ | last s == '.' = throwError $ IllegalState "expansion of class ctors not implemented yet"+ | head s == '.' = return $ PList [_pquote, Fix sym]+ | isJust $ fst (splitSym s) = return $ PList [_pquote, Fix sym]+ | otherwise = do newSym <- fromMaybe (Fix $ PSym $ "user/" ++ s)+ <$> liftM (fmap $ Fix . deSym . unFix)+ (getMapping s)+ return $ PList [_pquote, newSym]+ go lst@(PList []) = return lst+ go (PList xs)+ | head xs == _punquote = return $ unFix $ xs !! 1+ | head xs == _punquoteSplicing+ = throwError $ IllegalState "splice not in list"+ | otherwise = do seq <- sqExpand xs+ return $ PList [_pseq, iPList $ _pconcat : seq]+ go (PVec xs)+ = do seq <- sqExpand xs+ return $ PList [_papply, _pvector,+ iPList [_pseq, iPList $ _pconcat : seq]]+ go (PSet xs)+ = do seq <- sqExpand xs+ return $ PList [_papply, _phashset,+ iPList [_pseq, iPList $ _pconcat : seq]]+ go (PHM pairs)+ = do seq <- sqExpand (unpair pairs)+ return $ PList [_papply, _phashmap,+ iPList [_pseq, iPList $ _pconcat : seq]]+ go x = return x+ sqExpand = mapM (listGo . unFix)+ listGo lst@(PList []) = return $ iPList [_plist, Fix lst]+ listGo ls@(PList xs)+ | head xs == _punquote = return $ iPList [_plist, xs !! 1]+ | head xs == _punquoteSplicing+ = return $ xs !! 1+ | otherwise = do squote <- go ls+ return $ iPList [_plist, Fix squote]+ listGo x = do squote <- go x+ return $ iPList [_plist, Fix squote]+ unpair = concatMap (\(x,y) -> [x, y])+ gensym s cnt = Fix $ PSym $ init s ++ "__"+ ++ show cnt ++ "__auto__"+ -- TODO: This is hacky.+ _pquote = Fix $ PSym "quote"+ _punquote = Fix $ PSym "clojure.core/unquote"+ _punquoteSplicing = Fix $ PSym "clojure.core/unquote-splicing"+ _pconcat = Fix $ PSym "clojure.core/concat"+ _papply = Fix $ PSym "clojure.core/apply"+ _pvector = Fix $ PSym "clojure.core/vector"+ _phashmap = Fix $ PSym "clojure.core/hash-map"+ _phashset = Fix $ PSym "clojure.core/hash-set"+ _plist = Fix $ PSym "clojure.core/list"+ _pseq = Fix $ PSym "clojure.core/seq"+ deSym (ESym a b) = PSym $ maybe "" (++ "/") a ++ b+ deSym _ = error "getMapping returned non-sym back"+ iPList = Fix . PList
+ swearjure.cabal view
@@ -0,0 +1,42 @@+-- Initial swearjure.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: swearjure+version: 1.0.0+synopsis: Clojure without alphanumerics.+-- description: +homepage: http://www.swearjure.com+license: LGPL-3+license-file: COPYING.LESSER+author: Jean Niklas L'orange+maintainer: jeannikl@hypirion.com+-- copyright: +category: Language+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++executable swearjure+ main-is: Main.hs+ other-modules: Swearjure.AST+ Swearjure.Errors+ Swearjure.Eval+ Swearjure.Parser+ Swearjure.Primitives+ Swearjure.Reader+ -- other-extensions: + build-depends: base >=4.7 && <4.8+ , attoparsec >= 0.12+ , containers >= 0.5+ , fixplate >= 0.1+ , mtl >= 2.2+ , pretty >= 1.1+ , random >= 1.1+ , random-shuffle >= 0.0.4+ , readline >= 1.0.3.0+ , system-fileio >= 0.3+ , system-filepath >= 0.4+ , text >= 1.2+ -- Have a look at linenoise later.+ hs-source-dirs: src+ default-language: Haskell2010