husk-scheme-libs (empty) → 0.0.1

raw patch · 4 files changed

+149/−0 lines, 4 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, husk-scheme, json, mtl, transformers

Files

• LICENSE +19/−0
• Setup.hs +2/−0
• hs-src/Language/Scheme/Plugins/JSON.hs +104/−0
• husk-scheme-libs.cabal +24/−0

@@ -0,0 +1,19 @@+Copyright (c) 2010 Justin Ethier++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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,104 @@+{- |+Module      : Language.Scheme.Plugins.JSON+Copyright   : Justin Ethier+Licence     : MIT (see LICENSE in the distribution)++Maintainer  : github.com/justinethier+Portability : portable++This file implements an interface to Text.JSON that may+be called directly from husk using the FFI.+-}++module Language.Scheme.Plugins.JSON where ++import Control.Monad.Error+import Data.Array+import Data.Ratio+import Text.JSON+import Text.JSON.Generic+import qualified Language.Scheme.Numerical+import Language.Scheme.Types++-- ideas from http://therning.org/magnus/archives/719+instance JSON LispVal where+  showJSON (List []) = JSNull+  showJSON (String s) = JSString $ toJSString s+  showJSON (Atom s) = JSString $ toJSString s+  showJSON (Bool b) = JSBool b+  showJSON (Number n) = JSRational False $ fromIntegral n +  showJSON (Float n) = JSRational False $ toRational n +  showJSON (List l) = showJSONs l+  showJSON (Vector v) = do+    let ls = elems v+        f (List [Atom x, y]) = do+            (x, showJSON y)+    -- Take ls as an association list+    -- The alist is then changed into the form [(String, x)]+    -- and packaged into a JSObject+    JSObject $ toJSObject $ map f ls+  showJSON a = JSNull -- TODO (?): fail $ "Unable to convert to JSON: " ++ show a++  readJSON (JSNull) = return $ List []+  readJSON (JSString str) = return $ String $ fromJSString str+  readJSON (JSBool b) = return $ Bool b+  readJSON (JSRational _ num) = do+    let numer = abs $ numerator num+    let denom = abs $ denominator num+    case (numer >= denom) && ((mod numer denom) == 0) of+        True -> return $ Number $ round num+        _ -> return $ Float $ fromRational num+  readJSON (JSArray a) = do+    result <- mapM readJSON a+    return $ List $ result+  readJSON (JSObject o) = do+    let f (x,y) = do +        y' <- readJSON y+        return $ List [Atom x, y']++    ls <- mapM f (fromJSObject o)+    return $ Vector $ (listArray (0, length ls - 1)) ls++-- |Wrapper for Text.JSON.decode+jsDecode :: [LispVal] -> IOThrowsError LispVal+jsDecode [String json] = do+    let r = decode json :: Result LispVal+    case r of+        Ok result -> return result+        Error msg -> throwError $ Default msg+jsDecode invalid = throwError $ TypeMismatch "string" $ List invalid++-- |Wrapper for Text.JSON.decodeStrict+jsDecodeStrict :: [LispVal] -> IOThrowsError LispVal+jsDecodeStrict [String json] = do+    let r = decodeStrict json :: Result LispVal+    case r of+        Ok result -> return result+        Error msg -> throwError $ Default msg+jsDecodeStrict invalid = jsDecode invalid++-- |Wrapper for Text.JSON.encode+jsEncode :: [LispVal] -> IOThrowsError LispVal+jsEncode [val] = return $ String $ encode val++-- |Wrapper for Text.JSON.encodeStrict+jsEncodeStrict :: [LispVal] -> IOThrowsError LispVal+jsEncodeStrict [val] = return $ String $ encodeStrict val++_test :: IO ()+_test = do+    _testDecodeEncode "\"test\""+    _testDecodeEncode "true"+    _testDecodeEncode "null"+    _testDecodeEncode "1"+    _testDecodeEncode "1.5"+    _testDecodeEncode "[1.1, 2, 3, 1.5]"+    _testDecodeEncode "[1.1, 2, {\"a\": 3}, 1.5]"++_testDecodeEncode :: String -> IO ()+_testDecodeEncode str = do+    let x = decode  str :: Result LispVal+    case x of+        Ok x -> putStrLn $ encode x+        Error msg -> putStrLn $ "An error occurred: " ++ msg+

@@ -0,0 +1,24 @@+Name:                husk-scheme-libs+Version:             0.0.1+Synopsis:            Extra libraries for the husk Scheme platform.+Description:         Extra libraries for the husk Scheme platform.+License:             MIT+License-file:        LICENSE+Author:              Justin Ethier+Maintainer:          Justin Ethier <github.com/justinethier>+Homepage:            http://justinethier.github.com/husk-scheme+Cabal-Version:       >= 1.8+Build-Type:          Simple+Category:            Compilers/Interpreters, Language+Tested-with:         GHC == 7.2.2, GHC == 7.0.2, GHC == 6.12.3, GHC == 6.10.4++Extra-Source-Files:  LICENSE++Source-Repository head+    Type:            git+    Location:        git://github.com/justinethier/husk-scheme.git++Library+  Build-Depends:   base >= 2.0 && < 5, array, containers, json, husk-scheme, mtl, transformers+  Hs-Source-Dirs:  hs-src+  Exposed-Modules: Language.Scheme.Plugins.JSON