cypher (empty) → 0.1
raw patch · 7 files changed
+970/−0 lines, 7 filesdep +OneTupledep +aesondep +attoparsecsetup-changed
Dependencies added: OneTuple, aeson, attoparsec, base, bytestring, conduit, data-default, http-conduit, http-types, template-haskell, text, transformers, unordered-containers, vector
Files
- Data/Aeson/TH/Smart.hs +611/−0
- Data/Default/TH.hs +36/−0
- Database/Cypher.hs +155/−0
- Database/Cypher/Lucene.hs +63/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- cypher.cabal +73/−0
+ Data/Aeson/TH/Smart.hs view
@@ -0,0 +1,611 @@+{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-}+-- Shamelessly copied from Bryan O'Sullivan, 2011++module Data.Aeson.TH.Smart+ ( deriveJSON++ , deriveToJSON+ , deriveFromJSON++ , mkToJSON+ , mkParseJSON+ ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from aeson:+import Data.Aeson ( toJSON, Object, object, (.=), (.:)+ , ToJSON, toJSON+ , FromJSON, parseJSON+ )+import Data.Aeson.Types ( Value(..), Parser )+-- from base:+import Control.Applicative ( pure, (<$>), (<*>) )+import Control.Monad ( return, mapM, liftM2, fail )+import Data.Bool ( otherwise)+import Data.Default ( def, Default )+import Data.Eq ( (==) )+import Data.Function ( ($), (.), id )+import Data.Functor ( fmap )+import Data.List ( (++), foldl, foldl', intercalate+ , length, map, zip, genericLength+ )+import Data.Maybe ( Maybe(Nothing, Just) )+import Prelude ( String, (-), Integer, fromIntegral, not, error, filter, fst, snd, Bool(..), flip, concat)+import Text.Printf ( printf )+import Text.Show ( show )+#if __GLASGOW_HASKELL__ < 700+import Control.Monad ( (>>=) )+import Prelude ( fromInteger )+#endif+-- from unordered-containers:+import qualified Data.HashMap.Strict as H ( lookup, toList, size )+-- from template-haskell:+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+-- from text:+import qualified Data.Text as T ( Text, pack, unpack )+-- from vector:+import qualified Data.Vector as V ( unsafeIndex, null, length, create, filter)+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )++--------------------------------------------------------------------------------+-- Convenience+--------------------------------------------------------------------------------++-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given+-- data type.+--+-- This is a convienience function which is equivalent to calling both+-- 'deriveToJSON' and 'deriveFromJSON'.+deriveJSON :: (String -> String)+ -- ^ Function to change field names.+ -> Name+ -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'+ -- instances.+ -> Q [Dec]+deriveJSON withField name =+ liftM2 (++)+ (deriveToJSON withField name)+ (deriveFromJSON withField name)+++--------------------------------------------------------------------------------+-- ToJSON+--------------------------------------------------------------------------------++{-+TODO: Don't constrain phantom type variables.++data Foo a = Foo Int+instance (ToJSON a) ⇒ ToJSON Foo where ...++The above (ToJSON a) constraint is not necessary and perhaps undesirable.+-}++-- | Generates a 'ToJSON' instance declaration for the given data type.+--+-- Example:+--+-- @+-- data Foo = Foo 'Char' 'Int'+-- $('deriveToJSON' 'id' ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- instance 'ToJSON' Foo where+-- 'toJSON' =+-- \value -> case value of+-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do+-- mv <- 'VM.unsafeNew' 2+-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1)+-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2)+-- return mv+-- @+deriveToJSON :: (String -> String)+ -- ^ Function to change field names.+ -> Name+ -- ^ Name of the type for which to generate a 'ToJSON' instance+ -- declaration.+ -> Q [Dec]+deriveToJSON withField name =+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons+ where+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec+ fromCons tvbs cons =+ instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)+ (classType `appT` instanceType)+ [ funD 'toJSON+ [ clause []+ (normalB $ consToJSON withField cons)+ []+ ]+ ]+ where+ classType = conT ''ToJSON+ typeNames = map tvbName tvbs+ instanceType = foldl' appT (conT name) $ map varT typeNames++-- | Generates a lambda expression which encodes the given data type as JSON.+--+-- Example:+--+-- @+-- data Foo = Foo Int+-- @+--+-- @+-- encodeFoo :: Foo -> 'Value'+-- encodeFoo = $('mkToJSON' id ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- \value -> case value of Foo arg1 -> 'toJSON' arg1+-- @+mkToJSON :: (String -> String) -- ^ Function to change field names.+ -> Name -- ^ Name of the type to encode.+ -> Q Exp+mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)++-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code+-- to generate the JSON encoding of a number of constructors. All constructors+-- must be from the same type.+consToJSON :: (String -> String)+ -- ^ Function to change field names.+ -> [Con]+ -- ^ Constructors for which to generate JSON generating code.+ -> Q Exp+consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "+ ++ "Not a single constructor given!"+-- A single constructor is directly encoded. The constructor itself may be+-- forgotten.+consToJSON withField [con] = do+ value <- newName "value"+ lam1E (varP value)+ $ caseE (varE value)+ [encodeArgs Nothing withField con]++consToJSON withField cons = do+ value <- newName "value"+ lam1E (varP value)+ $ caseE (varE value)+ [ encodeArgs (Just $ wrap $ [|String . T.pack|] `appE` conNameExp con) withField con+ | con <- cons+ ]+ where+ wrap :: Q Exp -> [Q Exp] -> Q Exp+ wrap name exps =+ [e|object|] `appE` ([e| filter (not .(==Null) . snd )|] `appE`+ listE (infixApp (litE $ stringL "constructor") [e|(.=)|] name : exps))++-- | Generates code to generate the JSON encoding of a single constructor.+encodeArgs :: Maybe ([Q Exp] -> Q Exp) -> (String -> String) -> Con -> Q Match+encodeArgs _ _ c@(NormalC conName []) =+ match (conP conName []) (normalB $ [e|toJSON|] `appE` ([|T.pack|] `appE` conNameExp c)) []+encodeArgs wrapper _ (NormalC conName ts) = do+ let len = length ts+ args <- mapM newName ["arg" ++ show n | n <- [1..len]]+ let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of+ -- Single argument is directly converted.+ [e] -> e+ -- Multiple arguments are converted to a JSON array.+ es -> do+ mv <- newName "mv"+ let newMV = bindS (varP mv)+ ([e|VM.unsafeNew|] `appE`+ litE (integerL $ fromIntegral len))+ stmts = [noBindS $+ [e|VM.unsafeWrite|] `appE`+ (varE mv) `appE`+ litE (integerL ix) `appE` e | (ix, e) <- zip [(0::Integer)..] es]+ ret = noBindS $ [e|return|] `appE` varE mv+ fltr = [e| V.filter (not . (== Null))|]+ [e|Array|] `appE` (fltr `appE` (varE 'V.create `appE` doE (newMV:stmts++[ret])))+ let b = case wrapper of+ Nothing -> js+ (Just wrapper') -> wrapper' [infixApp (litE (stringL "value")) [e|(.=)|] js]+ match (conP conName $ map varP args) (normalB b) []+-- Records.+encodeArgs withExp withField (RecC conName ts) = do+ args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]+ let args' = map (([e|toJSON|] `appE`) . varE) args+ let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field) [e|(.=)|] arg+ | (arg, (field, _, _)) <- zip args' ts+ ]+ let b = case withExp of+ Nothing -> [e|object|] `appE` ([e| filter (not . (==Null) . snd) |] `appE` listE js)+ (Just wrapper) -> wrapper js+ match (conP conName $ map varP args) (normalB b) []+-- Infix constructors.+encodeArgs withExp _ (InfixC _ conName _) = do+ al <- newName "argL"+ ar <- newName "argR"+ let l = listE [[e|toJSON|] `appE` varE a | a <- [al,ar]]+ let b = case withExp of+ Nothing -> [e|toJSON|] `appE` l+ (Just wrapper) -> wrapper [infixApp (litE $ stringL "value") [e|(.=)|] l]+ match (infixP (varP al) conName (varP ar)) (normalB b) []+-- Existentially quantified constructors.+encodeArgs withExp withField (ForallC _ _ con) =+ encodeArgs withExp withField con+++--------------------------------------------------------------------------------+-- FromJSON+--------------------------------------------------------------------------------++-- | Generates a 'FromJSON' instance declaration for the given data type.+--+-- Example:+--+-- @+-- data Foo = Foo Char Int+-- $('deriveFromJSON' id ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- instance 'FromJSON' Foo where+-- 'parseJSON' =+-- \value -> case value of+-- 'Array' arr ->+-- if (V.length arr == 2)+-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)+-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)+-- else fail \"\<error message\>\"+-- other -> fail \"\<error message\>\"+-- @+deriveFromJSON :: (String -> String)+ -- ^ Function to change field names.+ -> Name+ -- ^ Name of the type for which to generate a 'FromJSON' instance+ -- declaration.+ -> Q [Dec]+deriveFromJSON withField name =+ withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons+ where+ fromCons :: [TyVarBndr] -> [Con] -> Q Dec+ fromCons tvbs cons =+ instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)+ (classType `appT` instanceType)+ [ funD 'parseJSON+ [ clause []+ (normalB $ consFromJSON name withField cons)+ []+ ]+ ]+ where+ classType = conT ''FromJSON+ typeNames = map tvbName tvbs+ instanceType = foldl' appT (conT name) $ map varT typeNames++-- | Generates a lambda expression which parses the JSON encoding of the given+-- data type.+--+-- Example:+--+-- @+-- data Foo = Foo 'Int'+-- @+--+-- @+-- parseFoo :: 'Value' -> 'Parser' Foo+-- parseFoo = $('mkParseJSON' id ''Foo)+-- @+--+-- This will splice in the following code:+--+-- @+-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg+-- @+mkParseJSON :: (String -> String) -- ^ Function to change field names.+ -> Name -- ^ Name of the encoded type.+ -> Q Exp+mkParseJSON withField name =+ withType name (\_ cons -> consFromJSON name withField cons)++-- if it's 1ary flat constrcutor, it's just the constructor name, no matter how many+-- if there's many nary constructors, we make an object with value and constructor records+-- if there's many record constructors, we add a record with the constructor value++-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates+-- code to parse the JSON encoding of a number of constructors. All constructors+-- must be from the same type.+consFromJSON :: Name+ -- ^ Name of the type to which the constructors belong.+ -> (String -> String)+ -- ^ Function to change field names.+ -> [Con]+ -- ^ Constructors for which to generate JSON parsing code.+ -> Q Exp+consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "+ ++ "Not a single constructor given!"+consFromJSON tName withField [con] = do+ value <- newName "value"+ lam1E (varP value)+ $ caseE (varE value)+ (parseArgs tName withField False con)++consFromJSON tName withField cons = do+ value <- newName "value"+ lam1E (varP value)+ $ caseE (varE value)+ $ concat [parseArgs tName withField True con | con <- cons]+++objectWrapper :: Name -> Name -> (Name -> Name -> ExpQ) -> [Q Match]+objectWrapper tName conName expr = + [ do obj <- newName "arg"+ strcon <- newName "strcon"+ val <- newName "val"+ flip (match (conP 'Object [varP obj])) [] $ normalB $ doE [+ bindS (varP strcon) ([e|(.: "constructor")|] `appE` (varE obj))+ , bindS (varP val) ([e|(.: "value")|] `appE` (varE obj))+ , guardConName conName val+ , noBindS (expr conName val)]+ , matchFailed tName conName "Object"+ ]++recWrapper :: Name -> Name -> (String -> String) -> Name -> [VarStrictType] -> [ExpQ]+recWrapper tName conName withField obj ts = + [ do+ b <- isInstance ''Default [ty]+ [|lookupField|]+ `appE` (if b then [| Just def |] else [| Nothing|])+ `appE` (litE $ stringL $ show tName)+ `appE` (litE $ stringL $ nameBase conName)+ `appE` (varE obj)+ `appE` ( [e|T.pack|]+ `appE`+ fieldNameExp withField field+ )+ | (field, _, ty) <- ts]+++-- | Generates code to parse the JSON encoding of a single constructor.+parseArgs :: Name -- ^ Name of the type to which the constructor belongs.+ -> (String -> String) -- ^ Function to change field names.+ -> Bool -- ^ Whether there are multiple constructors+ -> Con -- ^ Constructor for which to generate JSON parsing code.+ -> [Q Match]+-- Nullary constructors.+parseArgs tName _ _ (NormalC conName []) =+ [ do str <- newName "str"+ match (conP 'String [varP str])+ ( normalB $+ caseE (varE str)+ [ match (litP $ stringL $ nameBase conName) (normalB $ [e|return|] `appE` conE conName) []+ , match wildP (normalB $ wrongEnumerationError tName str) []+ ]+ ) []+ , matchFailed tName conName "String"+ ]+-- Unary constructors.+parseArgs _ _ False (NormalC conName [_]) =+ [ do arg <- newName "arg"+ match (varP arg)+ ( normalB $ infixApp (conE conName)+ [e|(<$>)|]+ ([e|parseJSON|] `appE` varE arg)+ )+ []+ ]+parseArgs tName _ True (NormalC conName [_]) =+ objectWrapper tName conName (\con val-> infixApp (conE con) [e|(<$>)|] ([e|parseJSON|] `appE` varE val))++-- Polyadic constructors.+parseArgs tName _ False (NormalC conName ts) = parseProduct tName conName $ genericLength ts+parseArgs tName _ True (NormalC conName ts) =+ objectWrapper tName conName (\con val-> caseE (varE val) (parseProduct tName con $ genericLength ts))++-- Records.+parseArgs tName withField False (RecC conName ts) =+ [ do obj <- newName "recObj"+ let x:xs = recWrapper tName conName withField obj ts+ match (conP 'Object [varP obj])+ ( normalB $ ( foldl' (\a b -> infixApp a [|(<*>)|] b)+ (infixApp (conE conName) [|(<$>)|] x)+ xs+ )+ )+ []+ , matchFailed tName conName "Object"+ ]++parseArgs tName withField True (RecC conName ts) =+ [ do obj <- newName "recObj"+ let xs = recWrapper tName conName withField obj ts+ x = [|lookupField Nothing|]+ `appE` (litE $ stringL $ show tName)+ `appE` (litE $ stringL $ nameBase conName)+ `appE` (varE obj)+ `appE` (litE $ stringL "constructor")+ match (conP 'Object [varP obj])+ ( normalB $ ( foldl' (\a b -> infixApp a [|(<*>)|] b)+ (infixApp (conE conName) [|(<$>)|] x)+ xs+ )+ )+ []+ , matchFailed tName conName "Object"+ ]++-- Infix constructors. Apart from syntax these are the same as+-- polyadic constructors.+parseArgs tName _ False (InfixC _ conName _) = parseProduct tName conName 2++parseArgs tName _ True (InfixC _ conName _) =+ objectWrapper tName conName (\con val -> caseE (varE val) (parseProduct tName con 2))++-- Existentially quantified constructors. We ignore the quantifiers+-- and proceed with the contained constructor.+parseArgs tName withField b (ForallC _ _ con) = parseArgs tName withField b con+++-- | Generates code to parse the JSON encoding of an n-ary+-- constructor.+parseProduct :: Name -- ^ Name of the type to which the constructor belongs.+ -> Name -- ^ 'Con'structor name.+ -> Integer -- ^ 'Con'structor arity.+ -> [Q Match]+parseProduct tName conName numArgs =+ [ do arr <- newName "arr"+ -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"+ let x:xs = [ [|parseJSON|]+ `appE`+ infixApp (varE arr)+ [|V.unsafeIndex|]+ (litE $ integerL ix)+ | ix <- [0 .. numArgs - 1]+ ]+ match (conP 'Array [varP arr])+ (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)+ [|(==)|]+ (litE $ integerL numArgs)+ )+ ( foldl' (\a b -> infixApp a [|(<*>)|] b)+ (infixApp (conE conName) [|(<$>)|] x)+ xs+ )+ ( parseTypeMismatch tName conName+ (litE $ stringL $ "Array of length " ++ show numArgs)+ ( infixApp (litE $ stringL $ "Array of length ")+ [|(++)|]+ ([|show . V.length|] `appE` varE arr)+ )+ )+ )+ []+ , matchFailed tName conName "Array"+ ]++lookupField :: (FromJSON a) => Maybe a -> String -> String -> Object -> T.Text -> Parser a+lookupField d tName rec obj key =+ case H.lookup key obj of+ Nothing -> case d of+ Nothing -> unknownFieldFail tName rec (T.unpack key)+ Just x -> return x+ Just v -> parseJSON v++--------------------------------------------------------------------------------+-- Parsing errors+--------------------------------------------------------------------------------++matchFailed :: Name -> Name -> String -> MatchQ+matchFailed tName conName expected = do+ other <- newName "other"+ match (varP other)+ ( normalB $ parseTypeMismatch tName conName+ (litE $ stringL expected)+ ([|valueConName|] `appE` varE other)+ )+ []++parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ+parseTypeMismatch tName conName expected actual =+ foldl appE+ [|parseTypeMismatch'|]+ [ litE $ stringL $ nameBase conName+ , litE $ stringL $ show tName+ , expected+ , actual+ ]++wrongEnumerationError :: Name -> Name -> ExpQ+wrongEnumerationError tName str = + [|wrongEnumerationError'|] `appE` (litE $ stringL $ nameBase tName) `appE` ([|T.unpack|] `appE` varE str)++unknownFieldFail :: String -> String -> String -> Parser fail+unknownFieldFail tName rec key =+ fail $ printf "When parsing the record %s of type %s the key %s was not present."+ rec tName key++noObjectFail :: String -> String -> Parser fail+noObjectFail t o =+ fail $ printf "When parsing %s expected Object but got %s." t o++wrongPairCountFail :: String -> String -> Parser fail+wrongPairCountFail t n =+ fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."+ t n++conNotFoundFail :: String -> [String] -> String -> Parser fail+conNotFoundFail t cs o =+ fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."+ t (intercalate ", " cs) o++parseTypeMismatch' :: String -> String -> String -> String -> Parser fail+parseTypeMismatch' tName conName expected actual =+ fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."+ conName tName expected actual++wrongEnumerationError' :: String -> String -> Parser fail+wrongEnumerationError' tName str = fail $ printf (str ++ " is not a data constructor for type " ++ tName)++--------------------------------------------------------------------------------+-- Utility functions+--------------------------------------------------------------------------------++-- | Boilerplate for top level splices.+--+-- The given 'Name' must be from a type constructor. Furthermore, the+-- type constructor must be either a data type or a newtype. Any other+-- value will result in an exception.+withType :: Name+ -> ([TyVarBndr] -> [Con] -> Q a)+ -- ^ Function that generates the actual code. Will be applied+ -- to the type variable binders and constructors extracted+ -- from the given 'Name'.+ -> Q a+ -- ^ Resulting value in the 'Q'uasi monad.+withType name f = do+ info <- reify name+ case info of+ TyConI dec ->+ case dec of+ DataD _ _ tvbs cons _ -> f tvbs cons+ NewtypeD _ _ tvbs con _ -> f tvbs [con]+ other -> error $ "Data.Aeson.TH.withType: Unsupported type: "+ ++ show other+ _ -> error "Data.Aeson.TH.withType: I need the name of a type."++-- | Extracts the name from a constructor.+getConName :: Con -> Name+getConName (NormalC name _) = name+getConName (RecC name _) = name+getConName (InfixC _ name _) = name+getConName (ForallC _ _ con) = getConName con++guardConName :: Name -> Name -> Q Stmt+guardConName conName varName = noBindS (infixApp (litE $ stringL $ nameBase conName) [e|(==)|] (varE varName))++-- | Extracts the name from a type variable binder.+tvbName :: TyVarBndr -> Name+tvbName (PlainTV name ) = name+tvbName (KindedTV name _) = name++-- | Makes a string literal expression from a constructor's name.+conNameExp :: Con -> Q Exp+conNameExp = litE . stringL . nameBase . getConName++-- | Creates a string literal expression from a record field name.+fieldNameExp :: (String -> String) -- ^ Function to change the field name.+ -> Name+ -> Q Exp+fieldNameExp f = litE . stringL . f . nameBase++-- | The name of the outermost 'Value' constructor.+valueConName :: Value -> String+valueConName (Object _) = "Object"+valueConName (Array _) = "Array"+valueConName (String _) = "String"+valueConName (Number _) = "Number"+valueConName (Bool _) = "Boolean"+valueConName Null = "Null"
+ Data/Default/TH.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Default.TH (deriveDefault) where++import Control.Applicative+import Data.Default+import Data.List+import Language.Haskell.TH++createInstance :: Name -> [Name] -> Name -> [Type] -> Q Dec+createInstance typeConstructorName typeVariables constructorName constructorArgumentTypes = do+ let reqs = constraints typeVariables+ return $ InstanceD reqs+ (AppT (ConT ''Default) (foldl' (\x y -> AppT x (VarT y)) (ConT typeConstructorName) typeVariables))+ [FunD 'def [Clause [] (NormalB (foldl' (\x _ -> AppE x (VarE 'def)) (ConE constructorName) constructorArgumentTypes)) []]]++constraints :: [Name] -> [Pred]+constraints = map (ClassP ''Default . return . VarT)++instanceQ :: Name -> [TyVarBndr] -> Name -> [Type] -> Q [Dec]+instanceQ t vs c as = return <$> createInstance t (map name vs) c as++name :: TyVarBndr -> Name+name (PlainTV n) = n+name (KindedTV n k) = n++deriveDefault :: Name -> Q [Dec]+deriveDefault n = do+ info <- reify n+ case info of+ TyConI (DataD _ qn tvars (con:_) _) -> case con of+ NormalC conName ts -> instanceQ qn tvars conName (map snd ts)+ RecC conName ts -> instanceQ qn tvars conName (map (\(v,s,t) -> t) ts)+ InfixC t conName t' -> instanceQ qn tvars conName (map snd [t, t'])+ _ -> fail $ "Dunno how to derive Default instances for existential types"+ TyConI (DataD _ _ _ [] _) -> fail $ "Really? You want to derive a Default instance for an uninhabited type?"+ _ -> fail $ "Couldn't derive a Default instance; didn't know what to do with " ++ pprint info
+ Database/Cypher.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, ScopedTypeVariables, FlexibleInstances #-}+module Database.Cypher (+ Cypher,+ Entity,+ CypherResult(..),+ runCypher,+ cypher,+ CypherException(..),+ Hostname,+ Port,+ OneTuple(..)+ ) where++import Data.Aeson+import Data.Aeson.TH+import Data.Aeson.Types+import Network.HTTP.Conduit+import Network.HTTP.Types+import Data.Conduit+import Data.Typeable+import Data.Text (Text)+import Data.Tuple.OneTuple+import Control.Exception+import Control.Applicative+import Control.Monad+import Data.Monoid+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++data DBInfo = DBInfo Hostname Port Manager+type Hostname = S.ByteString+type Port = Int++-- | All interaction with Neo4j is done through the Cypher monad. Use 'cypher' to add a query to the monad.+newtype Cypher a = Cypher {+ uncypher :: (DBInfo -> ResourceT IO a)+}++-- | Raw result data returned by Neo4j. Only use this if you care about column headers.+data CypherResult a = CypherResult {+ rescolumns :: [Text],+ resdata :: a+} deriving (Show, Eq)++data CypherRequest = CypherRequest {+ req_query :: Text,+ req_params :: Value+} deriving (Show, Eq)++-- | A neo4j node or edge+data Entity a = Entity {+ entity_id :: Text,+ entity_data :: a+} deriving (Show, Eq)++instance FromJSON a => FromJSON (Entity a) where+ parseJSON (Object v) = Entity <$>+ v .: "self" <*>+ v .: "data"+ parseJSON _ = mempty++instance ToJSON (Entity a) where+ toJSON = toJSON . entity_id++instance FromJSON a => FromJSON (OneTuple a) where+ parseJSON x = do+ [l] <- parseJSON x+ return $ OneTuple l++instance ToJSON a => ToJSON (OneTuple a) where+ toJSON = toJSON . (\x->[x])++$(deriveJSON (drop 3) ''CypherResult)+$(deriveJSON (drop 4) ''CypherRequest)++-- | An error in handling a Cypher query, either in communicating with the server or parsing the result+data CypherException = CypherServerException Status ResponseHeaders L.ByteString | + CypherClientParseException S.ByteString deriving (Show, Typeable)+instance Exception CypherException++throwClientParse bs = throw $ CypherClientParseException $ S.concat $ L.toChunks bs++instance Monad Cypher where+ return a = Cypher (const (return a))+ (Cypher cmd) >>= f =+ Cypher $ \con-> do+ a <- cmd con+ uncypher (f a) con++class FromCypher a where+ fromCypher :: L.ByteString -> a++instance FromCypher () where+ fromCypher _ = ()++instance FromJSON a => FromCypher (CypherResult a) where+ fromCypher bs = + case decode bs of+ Just x -> x+ Nothing -> throwClientParse bs++instance FromJSON a => FromCypher [a] where+ fromCypher bs =+ case decode bs of+ Just (CypherResult _ ds) -> ds+ _ -> throwClientParse bs++instance FromJSON a => FromCypher (OneTuple a) where+ fromCypher bs =+ case decode bs of+ Just (CypherResult _ [d]) -> d+ _ -> throwClientParse bs++instance (FromJSON a, FromJSON b) => FromCypher (a,b) where+ fromCypher bs =+ case decode bs of+ Just (CypherResult _ [d]) -> d+ _ -> throwClientParse bs++instance (FromJSON a, FromJSON b, FromJSON c) => FromCypher (a,b,c) where+ fromCypher bs =+ case decode bs of+ Just (CypherResult _ [d]) -> d+ _ -> throwClientParse bs++instance FromJSON a => FromCypher (Maybe a) where+ fromCypher bs =+ case decode bs of+ Just (CypherResult _ [a]) -> Just a+ Just (CypherResult _ []) -> Nothing+ _ -> throwClientParse bs++-- | Perform a cypher query+cypher :: FromCypher a => Text -> Value -> Cypher a+cypher txt params = Cypher $ \(DBInfo h p m)-> do+ let req = def { host = h, port = p,+ path = "db/data/cypher",+ requestBody = RequestBodyLBS (encode $ CypherRequest txt params),+ requestHeaders = headerAccept "application/json" : headerContentType "application/json" : requestHeaders def,+ method = "POST",+ checkStatus = (\_ _-> Nothing)+ }+ r <- httpLbs req m+ let sci = statusCode (responseStatus r)+ if 200 <= sci && sci < 300 then return (fromCypher (responseBody r))+ else throw $ CypherServerException (responseStatus r) (responseHeaders r) (responseBody r)++-- | Execute some number of cypher queries+runCypher :: Cypher a -> Hostname -> Port -> IO a+runCypher c h p =+ runResourceT $ do+ manager <- liftIO $ newManager def+ uncypher c (DBInfo h p manager)+
+ Database/Cypher/Lucene.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+-- Code shamelessly copied from Data.Aeson.Encode by MailRank, Inc.++module Database.Cypher.Lucene (luceneEncode) where+import Data.Aeson.Types (ToJSON(..), Value(..))+import Data.Attoparsec.Number (Number(..))+import Data.Monoid+import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Text.Lazy.Builder+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Text.Lazy.Builder.RealFloat (realFloat)+import Numeric (showHex)+import qualified Data.ByteString.Lazy as L+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Vector as V+++fromValue :: Value -> Builder+fromValue Null = mempty+fromValue (Bool b) = if b then "true" else "false"+fromValue (Number n) = fromNumber n+fromValue (String s) = string s+fromValue (Array v)+ | V.null v = mempty+ | otherwise = singleton '(' <>+ fromValue (V.unsafeHead v) <>+ V.foldr f (singleton ')') (V.unsafeTail v)+ where f a z = " OR " <> fromValue a <> z+fromValue (Object m) =+ case H.toList m of+ (x:xs) -> one x <> foldr f mempty xs+ _ -> mempty+ where f a z = let n = one a in if n == "" then z else " AND " <> n <> z+ one (k,v) = let n = fromValue v in if n == "" then n else fromText k <> singleton ':' <> n++string :: T.Text -> Builder+string s = singleton '"' <> quote s <> singleton '"'+ where+ quote q = case T.uncons t of+ Nothing -> fromText h+ Just (!c,t') -> fromText h <> escape c <> quote t'+ where (h,t) = {-# SCC "break" #-} T.break isEscape q+ isEscape c = c == '\"' || c == '\\' || c < '\x20'+ escape '\"' = "\\\""+ escape '\\' = "\\\\"+ escape '\n' = "\\n"+ escape '\r' = "\\r"+ escape '\t' = "\\t"+ escape c+ | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h+ | otherwise = singleton c+ where h = showHex (fromEnum c) ""++fromNumber :: Number -> Builder+fromNumber (I i) = decimal i+fromNumber (D d)+ | isNaN d || isInfinite d = "null"+ | otherwise = realFloat d++-- | Convert an object to a Lucene query encoded as an 'L.ByteString'.+luceneEncode :: ToJSON a => a -> L.ByteString+luceneEncode = encodeUtf8 . toLazyText . fromValue . toJSON
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Sam Anklesaria, Lasso Inc++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sam Anklesaria nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cypher.cabal view
@@ -0,0 +1,73 @@+-- cypher.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: cypher++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.1++-- A short (one-line) description of the package.+Synopsis: Haskell bindings for the neo4j "cypher" query language+Description: haskell-cypher makes it easy to send cypher commands to neo4j servers over their REST API. + Additionally, it allows users to parse haskell datatypes from "cypher" queries.++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Sam Anklesaria++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: amsay@amsay.net++-- A copyright notice.+-- Copyright: ++Category: Database++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.6++source-repository head+ type: git+ location: git://github.com/lassoinc/haskell-cypher.git++Library+ -- Modules exported by the library.+ Exposed-modules: Database.Cypher, Database.Cypher.Lucene, Data.Aeson.TH.Smart, Data.Default.TH+ + -- Packages needed in order to build this package.+ Build-depends: base < 5+ , aeson+ , http-conduit+ , transformers+ , conduit+ , text+ , bytestring+ , http-types <1+ , vector <1+ , unordered-containers <1+ , attoparsec <1+ , OneTuple <1+ , data-default <1+ , template-haskell >= 2.7+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +