Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Prototyping serialization without typeclasses in the haskell backend #128

Draft
wants to merge 1 commit into
base: master
Choose a base branch
from
Draft

Prototyping serialization without typeclasses in the haskell backend #128

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
89 changes: 47 additions & 42 deletions haskell/compiler/tests/demo1/hs-output/ADL/Picture.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -26,15 +26,15 @@ data Circle = Circle
mkCircle :: Prelude.Double -> Circle
mkCircle radius = Circle radius

instance AdlValue Circle where
atype _ = "picture.Circle"

jsonGen = genObject
jbCircle :: JsonBinding Circle
jbCircle = JsonBinding
{ atype_ = "picture.Circle"
, jsonGen_ = genObject
[ genField "radius" circle_radius
]

jsonParser = Circle
, jsonParser_ = Circle
<$> parseField "radius"
}

data Picture
= Picture_circle Circle
Expand All @@ -43,22 +43,24 @@ data Picture
| Picture_translated (Translated Picture)
deriving (Prelude.Eq,Prelude.Ord,Prelude.Show)

instance AdlValue Picture where
atype _ = "picture.Picture"
jbPicture :: JsonBinding Picture
jbPicture = JsonBinding
{ atype_ = "picture.Picture"

jsonGen = genUnion (\jv -> case jv of
Picture_circle v -> genUnionValue "circle" v
Picture_rectangle v -> genUnionValue "rectangle" v
Picture_composed v -> genUnionValue "composed" v
Picture_translated v -> genUnionValue "translated" v
, jsonGen_ = genUnion (\jv -> case jv of
Picture_circle v -> genUnionValue_ jbCircle "circle" v
Picture_rectangle v -> genUnionValue_ jbRectangle "rectangle" v
Picture_composed v -> genUnionValue_ (jbVector jbPicture) "composed" v
Picture_translated v -> genUnionValue_ (jbTranslated jbPicture) "translated" v
)

jsonParser = parseUnion $ \disc -> case disc of
"circle" -> parseUnionValue Picture_circle
"rectangle" -> parseUnionValue Picture_rectangle
"composed" -> parseUnionValue Picture_composed
"translated" -> parseUnionValue Picture_translated
_ -> parseFail "expected a discriminator for Picture (circle,rectangle,composed,translated)"
, jsonParser_ = parseUnion $ \disc -> case disc of
"circle" -> parseUnionValue_ jbCircle Picture_circle
"rectangle" -> parseUnionValue_ jbRectangle Picture_rectangle
"composed" -> parseUnionValue_ (jbVector jbPicture) Picture_composed
"translated" -> parseUnionValue_ (jbTranslated jbPicture) Picture_translated
_ -> parseFail "expected a discriminator for Picture (circle,rectangle,composed,translated)"
}

data Rectangle = Rectangle
{ rectangle_width :: Prelude.Double
Expand All @@ -69,18 +71,19 @@ data Rectangle = Rectangle
mkRectangle :: Prelude.Double -> Prelude.Double -> Rectangle
mkRectangle width height = Rectangle width height

instance AdlValue Rectangle where
atype _ = "picture.Rectangle"

jsonGen = genObject
[ genField "width" rectangle_width
, genField "height" rectangle_height
]

jsonParser = Rectangle
<$> parseField "width"
<*> parseField "height"

jbRectangle :: JsonBinding Rectangle
jbRectangle = JsonBinding
{ atype_ = "picture.Rectangle"
, jsonGen_ = genObject
[ genField_ jbDouble "width" rectangle_width
, genField_ jbDouble "height" rectangle_height
]

, jsonParser_ = Rectangle
<$> parseField_ jbDouble "width"
<*> parseField_ jbDouble "height"
}
--
data Translated t = Translated
{ translated_xoffset :: Prelude.Double
, translated_yoffset :: Prelude.Double
Expand All @@ -91,19 +94,21 @@ data Translated t = Translated
mkTranslated :: t -> Translated t
mkTranslated object = Translated 0 0 object

instance (AdlValue t) => AdlValue (Translated t) where
atype _ = T.concat
jbTranslated :: JsonBinding a -> JsonBinding (Translated a)
jbTranslated jbA = JsonBinding
{ atype_ = T.concat
[ "picture.Translated"
, "<", atype (Data.Proxy.Proxy :: Data.Proxy.Proxy t)
, "<", atype_ jbA
, ">" ]

jsonGen = genObject
[ genField "xoffset" translated_xoffset
, genField "yoffset" translated_yoffset
, genField "object" translated_object
, jsonGen_ = genObject
[ genField_ jbDouble "xoffset" translated_xoffset
, genField_ jbDouble "yoffset" translated_yoffset
, genField_ jbA "object" translated_object
]

jsonParser = Translated
<$> parseFieldDef "xoffset" 0
<*> parseFieldDef "yoffset" 0
<*> parseField "object"
, jsonParser_ = Translated
<$> parseFieldDef_ jbDouble "xoffset" 0
<*> parseFieldDef_ jbDouble "yoffset" 0
<*> parseField_ jbA "object"
}
51 changes: 50 additions & 1 deletion haskell/runtime/src/ADL/Core/Value.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
module ADL.Core.Value(
JsonGen(..),
JsonParser(..),
JsonBinding(..),
ParseResult(..),
ParseContextItem(..),
AdlValue(..),
Expand All @@ -15,18 +16,25 @@ module ADL.Core.Value(
adlToJsonFile,
decodeAdlParseResult,
genField,
genField_,
genObject,
genUnion,
genUnionValue,
genUnionValue_,
genUnionVoid,
parseField,
parseField_,
parseFieldDef,
parseFieldDef_,
parseUnion,
parseUnionValue,
parseUnionValue_,
parseUnionVoid,
parseFail,
textFromParseContext,
withJsonObject
withJsonObject,
jbVector,
jbDouble,
) where

import qualified Data.Aeson as JS
Expand All @@ -52,6 +60,19 @@ newtype JsonGen a = JsonGen {runJsonGen :: a -> JS.Value}
-- | A Json parser
newtype JsonParser a = JsonParser {runJsonParser :: ParseContext -> JS.Value -> ParseResult a}

data JsonBinding a = JsonBinding {

-- | A text string describing the type.
atype_ :: T.Text,

-- | A JSON generator for this ADL type
jsonGen_ :: JsonGen a,

-- | A JSON parser for this ADL type
jsonParser_ :: JsonParser a
}


-- | A path within a json value, used in error reporting
type ParseContext = [ParseContextItem]

Expand Down Expand Up @@ -110,6 +131,9 @@ parseNull = jsonParser
adlToJson :: AdlValue a => a -> JS.Value
adlToJson = runJsonGen jsonGen

adlToJson_ :: JsonBinding a -> a -> JS.Value
adlToJson_ jb = runJsonGen (jsonGen_ jb)

-- Convert a JSON value to an ADL value
adlFromJson :: AdlValue a => JS.Value -> ParseResult a
adlFromJson = runJsonParser jsonParser []
Expand Down Expand Up @@ -163,12 +187,18 @@ genObject fieldfns = JsonGen (\o -> JS.object [f o | f <- fieldfns])
genField :: AdlValue a => T.Text -> (o -> a) -> o -> (T.Text, JS.Value)
genField label f o = (label,adlToJson (f o))

genField_ :: JsonBinding a -> T.Text -> (o -> a) -> o -> (T.Text, JS.Value)
genField_ jb label f o = (label,adlToJson_ jb (f o))

genUnion :: (u -> JS.Value) -> JsonGen u
genUnion f = JsonGen f

genUnionValue :: AdlValue a => T.Text -> a -> JS.Value
genUnionValue disc a = JS.object [(disc,adlToJson a)]

genUnionValue_ :: JsonBinding a -> T.Text -> a -> JS.Value
genUnionValue_ jb disc a = JS.object [(disc,adlToJson_ jb a)]

genUnionVoid :: T.Text -> JS.Value
genUnionVoid disc = JS.toJSON disc

Expand All @@ -177,11 +207,21 @@ parseField label = withJsonObject $ \ctx hm -> case HM.lookup label hm of
(Just b) -> runJsonParser jsonParser (ParseField label:ctx) b
_ -> ParseFailure ("expected field " <> label) ctx

parseField_ :: JsonBinding a -> T.Text -> JsonParser a
parseField_ jb label = withJsonObject $ \ctx hm -> case HM.lookup label hm of
(Just b) -> runJsonParser (jsonParser_ jb) (ParseField label:ctx) b
_ -> ParseFailure ("expected field " <> label) ctx

parseFieldDef :: AdlValue a => T.Text -> a -> JsonParser a
parseFieldDef label defv = withJsonObject $ \ctx hm -> case HM.lookup label hm of
(Just b) -> runJsonParser jsonParser (ParseField label:ctx) b
_ -> pure defv

parseFieldDef_ :: JsonBinding a -> T.Text -> a -> JsonParser a
parseFieldDef_ jb label defv = withJsonObject $ \ctx hm -> case HM.lookup label hm of
(Just b) -> runJsonParser (jsonParser_ jb) (ParseField label:ctx) b
_ -> pure defv

parseUnion :: ( T.Text -> JsonParser a) -> JsonParser a
parseUnion parseCase = JsonParser $ \ctx jv0 -> case parse0 ctx jv0 of
ParseFailure emesg ctx -> ParseFailure emesg ctx
Expand All @@ -199,6 +239,9 @@ parseUnionVoid a = pure a <* parseNull
parseUnionValue :: AdlValue b => (b -> a) -> JsonParser a
parseUnionValue fa = fa <$> jsonParser

parseUnionValue_ :: JsonBinding b -> (b -> a) -> JsonParser a
parseUnionValue_ jb fa = fa <$> (jsonParser_ jb)

withJsonObject :: (ParseContext -> JS.Object -> ParseResult a) -> JsonParser a
withJsonObject f = JsonParser $ \ctx jv -> case jv of
(JS.Object hm) -> f ctx hm
Expand Down Expand Up @@ -277,6 +320,9 @@ instance AdlValue Double where
jsonGen = JsonGen (JS.Number . SC.fromFloatDigits)
jsonParser = withJsonNumber (\_ n -> pure (SC.toRealFloat n))

jbDouble :: JsonBinding Double
jbDouble = undefined

instance AdlValue Float where
atype _ = "Float"
jsonGen = JsonGen (JS.Number . SC.fromFloatDigits)
Expand Down Expand Up @@ -307,6 +353,9 @@ instance forall a . (AdlValue a) => AdlValue [a] where
in traverse parse (zip [0,1..] (V.toList a))
_ -> ParseFailure "expected an array" ctx

jbVector :: JsonBinding a -> JsonBinding [a]
jbVector = undefined

instance (AdlValue t) => AdlValue (Maybe t) where
atype _ = T.concat
[ "sys.types.Maybe"
Expand Down