sourcecode: 
|
module CurryDoc.Generators.JSON ( generateJSON ) where
import CurryDoc.Info
import CurryDoc.Info.Export
import CurryDoc.Data.CurryDoc
import JSON.Data
import JSON.Pretty
import AbstractCurry.Types
import AbstractCurry.Pretty
import Text.Pretty
import Data.List
class ToJSON a where
toJSON :: a -> JValue
-- | Converts a CurryDoc to a JSON string.
generateJSON :: CurryDoc -> IO String
generateJSON = return . ppJSON . toJSON
instance ToJSON CurryDoc where
toJSON (CurryDoc name (ModuleHeader header _) ds _) = JObject
([("module", JString name)] ++
map jsonHeader header ++
[jsonFunctions fs, jsonTypes ts, jsonTypeclasses cs])
where ds' = flattenExport ds
fs = filter isCurryDocFuncDecl ds'
ts = filter isCurryDocTypeDecl ds'
cs = filter isCurryDocClassDecl ds'
instance ToJSON CurryDocDecl where
toJSON (CurryDocTypeDecl (mname, name) vs ty cs) = JObject
[ ( "datatype", JString "type" )
, ( "module-name", JString mname )
, ( "type-variables", jsonVars vs )
, ( "name", JString name )
, ( "type", toJSON ty )
, ( "comments", toJSON cs )]
toJSON (CurryDocDataDecl (mname, name) vs _ ex cons cs) = JObject
[ ( "datatype", JString "data" )
, ( "module-name", JString mname )
, ( "name", JString name )
, ( "type-variables", jsonVars vs )
, ( "external", toJSON ex )
, ( "constructors", JArray (map (toJSONCons r) cons ))
, ( "comments", toJSON cs )]
where r = foldr (\v t -> CTApply t (CTVar v)) (CTCons (mname, name)) vs
toJSON (CurryDocNewtypeDecl (mname, name) vs _ cons cs) = JObject
[ ( "datatype", JString "newtype" )
, ( "module-name", JString mname )
, ( "name", JString name )
, ( "type-variables", jsonVars vs )
, ( "constructors", JArray (map (toJSONCons r) cons'))
, ( "comments", toJSON cs )]
where r = foldr (\v t -> CTApply t (CTVar v)) (CTCons (mname, name)) vs
cons' = case cons of
Just c -> [c]
Nothing -> []
toJSON (CurryDocClassDecl (mname, name) cx vs fdeps ds cs) = JObject
[ ( "module-name", JString mname )
, ( "name", JString name )
, ( "context", toJSON cx )
, ( "type-variables", JArray $ map jsonVar vs)
, ( "class-functions", toJSON ds )
, ( "functional-deps", toJSON fdeps )
, ( "comments", toJSON cs )]
toJSON (CurryDocFunctionDecl (mname, name) ty _ _ cs) = JObject
[ ("module-name", JString mname)
, ( "name", JString name)
, ( "type", toJSON ty )
, ( "comments", toJSON cs )]
instance ToJSON CurryDocFunDep where
toJSON (CurryDocFunDep (xs, ys)) = JObject
[ ("lhs", jsonVars xs)
, ("rhs", jsonVars ys)]
instance ToJSON a => ToJSON [a] where
toJSON = JArray . map toJSON
instance ToJSON Bool where
toJSON True = JTrue
toJSON False = JFalse
instance ToJSON CContext where
toJSON (CContext cs) = JArray (map (JString . ppConstraint) cs)
instance ToJSON CQualTypeExpr where
toJSON (CQualType (CContext [] ) ty) =
JString (ppType ty)
toJSON (CQualType (CContext [x] ) ty) =
JString (ppConstraint x ++ " => " ++ ppType ty)
toJSON (CQualType (CContext xs@(_:_:_)) ty) =
JString ("(" ++ intercalate ", " (map ppConstraint xs) ++ ") => "
++ ppType ty)
instance ToJSON CTypeExpr where
toJSON = JString . ppType
instance ToJSON Comment where
toJSON (NestedComment c) = JString c
toJSON (LineComment c) = JString c
toJSONCons :: CTypeExpr -> CurryDocCons -> JValue
toJSONCons ty (CurryDocConstr (mname, name) args _ cs) = JObject
[ ("constructor", JString "constructor" )
, ("module-name", JString mname )
, ( "name", JString name )
, ( "type", jsonListTypes (args ++ [ty]) )
, ( "comments", toJSON cs )]
toJSONCons ty (CurryDocConsOp (mname, name) arg1 arg2 _ cs) = JObject
[ ("constructor", JString "operator" )
, ("module-name", JString mname )
, ( "name", JString name )
, ( "type", jsonListTypes [arg1, arg2, ty])
, ( "comments", toJSON cs )]
toJSONCons ty (CurryDocRecord (mname, name) args fields _ cs) = JObject
[ ("constructor", JString "constructor" )
, ("module-name", JString mname )
, ( "name", JString name )
, ( "type", jsonListTypes (args ++ [ty]) )
, ( "fields", toJSON fields )
, ( "comments", toJSON cs )]
instance ToJSON CurryDocField where
toJSON (CurryDocField (mname, name) ty _ cs) = JObject
[ ("module-name", JString mname)
, ( "name", JString name)
, ( "type", toJSON ty )
, ( "comments", toJSON cs )]
jsonListTypes :: [CTypeExpr] -> JValue
jsonListTypes = JString . intercalate " -> " . map ppType
jsonVar :: CTVarIName -> JValue
jsonVar = JString . snd
jsonVars :: [CTVarIName] -> JValue
jsonVars = JArray . map jsonVar
ppConstraint :: CConstraint -> String
ppConstraint ((_, name), ts) = name ++ " " ++ unwords (map ppType ts)
ppType :: CTypeExpr -> String
ppType = unwords . concatMap words . lines
. pPrint . ppCTypeExpr (setNoQualification defaultOptions)
jsonHeader :: (HeaderField, String) -> (String, JValue)
jsonHeader (Description, d) = ("description", JString d)
jsonHeader (Category , d) = ("category" , JString d)
jsonHeader (Author , d) = ("author" , JString d)
jsonHeader (Version , d) = ("version" , JString d)
jsonFunctions :: [CurryDocDecl] -> (String, JValue)
jsonFunctions ds = ("functions" , toJSON ds)
jsonTypes :: [CurryDocDecl] -> (String, JValue)
jsonTypes ds = ("types" , toJSON ds)
jsonTypeclasses :: [CurryDocDecl] -> (String, JValue)
jsonTypeclasses ds = ("typeclasses", toJSON ds)
|