module YesodDsl.Generator.Json (moduleToJson) where
import YesodDsl.AST
import Data.Aeson.Encode.Pretty
import qualified Data.Text as T
import Data.Aeson
import Data.Maybe
import qualified Data.Vector as V
import qualified Data.Text.Lazy.Encoding as LTE
import YesodDsl.Generator.Input
import qualified Data.Text.Lazy as LT
moduleToJson :: Module -> String
moduleToJson m = LT.unpack $ LTE.decodeUtf8 $ encodePretty $ object [
"name" .= moduleName m,
"classes" .= [
object [
"name" .= className c,
"fields" .= [ fieldJson f | f <- classFields c, fieldInternal f == False, fieldReadOnly f == False ],
"instances" .= [ entityName e | e <- modEntities m,
className c `elem` entityInstances e ]
] | c <- modClasses m
],
"entities" .= [
object [
"name" .= entityName e,
"fields" .= [ fieldJson f | f <- entityFields e, fieldInternal f == False, fieldReadOnly f == False ]
] | e <- modEntities m
],
"enums" .= [
object [
"name" .= enumName e,
"values" .= enumValues e
] | e <- modEnums m
],
"routes" .= [
object [
"path" .= [
case pp of
PathText s -> object [
"type" .= ("string" :: String),
"references" .= ("null" :: String),
"value" .= s
]
PathId _ en -> object [
"type" .= ("integer" :: String),
"references" .= en
]
| pp <- routePath r
],
"handlers" .= [
object [
"public" .= (Public `elem` (handlerStmts h)),
"type" .= (show $ handlerType h),
"inputs" .= [
object [
"name" .= fn,
"type" .= (mfc >>= Just . toJSON . jsonFieldType . fieldContent),
"references" .= (mfc >>= Just . toJSON . jsonFieldReferences . fieldContent)
]
| (fn, mfc) <- nubAttrs $ concatMap requestAttrs $ handlerStmts h
],
"outputs" .= (concatMap outputs $ handlerStmts h)
] | h <- routeHandlers r
]
] | r <- modRoutes m
]
]
where
outputs hp = case hp of
Select sq -> map selectField $ sqFields sq
Return ofs -> [
object [
"name" .= pn,
"type" .= Null
] | (pn,_,_) <- ofs
]
_ -> []
selectField sf = object [
"name" .= name,
"type" .= type_,
"references" .= references
]
where
name = case sf of
SelectField _ fn mvn -> fromMaybe fn mvn
SelectIdField _ mvn -> fromMaybe "id" mvn
SelectExpr _ vn -> vn
_ -> ""
type_ = case sf of
SelectField (Var _ (Right e) _) fn _ -> fromMaybe Null $ lookupField e fn >>= Just . toJSON . jsonFieldType . fieldContent
SelectIdField _ _ -> String "integer"
SelectExpr ve _ -> case ve of
ConcatManyExpr _ -> String "string"
BinOpExpr _ Concat _ -> String "string"
BinOpExpr _ _ _ -> String "number"
UnOpExpr Floor _ -> String "number"
UnOpExpr Ceiling _ -> String "number"
UnOpExpr Not _ -> String "boolean"
UnOpExpr (Extract _) _ -> String "string"
_ -> Null
_ -> Null
references = case sf of
SelectIdField (Var _ (Right e) _) _ -> String $ T.pack $ entityName e
SelectField (Var _ (Right e) _) fn _ -> fromMaybe Null $ lookupField e fn >>= Just . jsonFieldReferences . fieldContent
_ -> Null
fieldJson f = object [
"name" .= fieldJsonName f,
"optional" .= fieldOptional f,
"default" .= (fieldDefault f >>= fieldValueJson),
"references" .= (jsonFieldReferences $ fieldContent f),
"type" .= (jsonFieldType $ fieldContent f)
]
jsonFieldReferences fc = case fc of
EntityField en -> toJSON en
EnumField en -> toJSON en
_ -> Null
jsonFieldType fc = case fc of
NormalField ft -> case ft of
FTWord32 -> "integer"
FTWord64 -> "integer"
FTInt32 -> "integer"
FTInt -> "integer"
FTInt64 -> "integer"
FTText -> "string"
FTBool -> "boolean"
FTDouble -> "number"
FTRational -> "number"
FTTimeOfDay -> "timeofday"
FTDay -> "day"
FTUTCTime -> "utctime"
FTCheckmark -> "boolean"
EntityField _ -> "integer"
EnumField _ -> ("string" :: String)
fieldValueJson fv = Just $ case fv of
StringValue s -> toJSON s
IntValue i -> toJSON i
FloatValue f -> toJSON f
BoolValue b -> toJSON b
NothingValue -> Null
CheckmarkValue cv -> toJSON $ show cv
EnumFieldValue _ ev -> toJSON ev
EmptyList -> Array V.empty