Added DynamicSchema and started to add documentation

Codec/ActivityStream/Dynamic.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
 
 {-|
 Module      : Codec.ActivityStream.Dynamic
@@ -74,52 +73,13 @@ import           Data.Aeson ( FromJSON(..)
 import qualified Data.Aeson as A
 import           Data.DateTime (DateTime)
 import qualified Data.HashMap.Strict as HM
-import           Data.Maybe (fromJust)
 import           Data.Text (Text)
 
-
-newtype Const a b = Const { fromConst :: a }
-instance Functor (Const a) where fmap f (Const x) = Const x
-
-newtype Id a = Id { fromId :: a }
-instance Functor Id where fmap f (Id x) = Id (f x)
-
-type Lens' a b = forall f. Functor f => (b -> f b) -> (a -> f a)
-
-get :: Lens' a b -> a -> b
-get lens a = fromConst (lens Const a)
-
-set :: Lens' a b -> b -> a -> a
-set lens x a = fromId (lens (const Id x) a)
-
-makeLens :: (a -> b) -> (b -> a -> a) -> Lens' a b
-makeLens get set f a = (`set` a) `fmap` f (get a)
-
-fromJSON' :: FromJSON a => A.Value -> Maybe a
-fromJSON' v = case fromJSON v of
-  Success a -> Just a
-  Error _   -> Nothing
-
-makeAesonLensMb :: (FromJSON v, ToJSON v)
-              => Text -> Lens' c A.Object -> Lens' c (Maybe v)
-makeAesonLensMb key fromObj = fromObj . lens
-  where lens = makeLens
-                 (\ o -> HM.lookup key o >>= fromJSON')
-                 (\ v o -> HM.insert key (toJSON (Just v)) o)
-
-
-makeAesonLens :: (FromJSON v, ToJSON v) => Text -> Lens' c A.Object -> Lens' c v
-makeAesonLens key fromObj = fromObj . lens
-  where lens = makeLens
-                 (\ o -> fromJust (HM.lookup key o >>= fromJSON'))
-                 (\ v o -> HM.insert key (toJSON v) o)
+import Codec.ActivityStream.LensInternal ( Lens'
+                                         , makeLens
+                                         , makeAesonLens
+                                         , makeAesonLensMb
+                                         )
 
 data MediaLink = MediaLink { fromMediaLink :: A.Object } deriving (Eq, Show)
 

Codec/ActivityStream/DynamicSchema.hs

@@ -0,0 +1,268 @@
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Codec.ActivityStream.DynamicSchema
+  ( module Codec.ActivityStream.Dynamic
+  -- * Verbs
+  , SchemaVerb(..)
+  -- * Object Types
+  , SchemaObjectType(..)
+  -- ** Audio/Video
+  , avEmbedCode
+  , avStream
+  -- ** Binary
+  , bnCompression
+  , bnData
+  , bnFileUrl
+  , bnLength
+  , bnMd5
+  , bnMimeType
+  -- ** Event
+  , evAttended
+  , evAttending
+  , evEndTime
+  , evInvited
+  , evMaybeAttending
+  , evNotAttendedBy
+  , evNotAttending
+  , evStartTime
+  -- ** Issue
+  , isTypes
+  -- ** Permission
+  , pmScope
+  , pmActions
+  -- ** Place
+  , plPosition
+  , plAddress
+  -- *** PlacePosition
+  , PlacePosition
+  -- *** PlaceAddress
+  , PlaceAddress
+  -- ** Role/Group
+  , rlMembers
+  -- ** Task
+  , tsActor
+  , tsBy
+  , tsObject
+  , tsPrerequisites
+  , tsRequired
+  , tsSupersedes
+  , tsVerb
+  -- * Basic Extension Properties
+  , acContext
+  , getLocation
+  , oMood
+  , oRating
+  , acResult
+  , getSource
+  , getStartTime
+  , getEndTime
+  , Mood
+  , moodRest
+  , moodDisplayName
+  , moodImage
+  ) where
+
+import qualified Data.Aeson as Aeson
+import           Data.DateTime (DateTime)
+import           Data.Aeson ( FromJSON(..), ToJSON(..) )
+import qualified Data.HashMap.Strict as HM
+import           Data.Text (Text)
+
+import Codec.ActivityStream.LensInternal
+import Codec.ActivityStream.Dynamic
+import Codec.ActivityStream.Schema (SchemaVerb(..), SchemaObjectType(..))
+
+-- audio/video
+
+-- | A fragment of HTML markup that, when embedded within another HTML
+--   page, provides an interactive user-interface for viewing or listening
+--   to the video or audio stream.
+avEmbedCode :: Lens' Object (Maybe Text)
+avEmbedCode = makeAesonLensMb "embedCode" oRest
+
+-- | An Activity Streams Media Link to the video or audio content itself.
+avStream :: Lens' Object (Maybe MediaLink)
+avStream = makeAesonLensMb "stream" oRest
+
+-- binary
+
+-- | An optional token identifying a compression algorithm applied to
+--   the binary data prior to Base64-encoding. Possible algorithms
+--   are "deflate" and "gzip", respectively indicating the use of
+--   the compression mechanisms defined by RFC 1951 and RFC 1952.
+--   Additional compression algorithms MAY be used but are not defined
+--   by this specification. Note that previous versions of this
+--   specification allowed for multiple compression algorithms to be
+--   applied and listed using a comma-separated format. The use of
+--   multiple compressions is no longer permitted.
+bnCompression :: Lens' Object (Maybe Text)
+bnCompression = makeAesonLensMb "compression" oRest
+
+bnData :: Lens' Object (Maybe Text)
+bnData = makeAesonLensMb "data" oRest
+
+bnFileUrl :: Lens' Object (Maybe Text)
+bnFileUrl = makeAesonLensMb "fileUrl" oRest
+
+bnLength :: Lens' Object (Maybe Text)
+bnLength = makeAesonLensMb "length" oRest
+
+bnMd5 :: Lens' Object (Maybe Text)
+bnMd5 = makeAesonLensMb "md5" oRest
+
+bnMimeType :: Lens' Object (Maybe Text)
+bnMimeType = makeAesonLensMb "mimeType" oRest
+
+-- event
+
+evAttended :: Lens' Object (Maybe Collection)
+evAttended = makeAesonLensMb "attended" oRest
+
+evAttending :: Lens' Object (Maybe Collection)
+evAttending = makeAesonLensMb "attending" oRest
+
+evEndTime :: Lens' Object (Maybe DateTime)
+evEndTime = makeAesonLensMb "endTime" oRest
+
+evInvited :: Lens' Object (Maybe Collection)
+evInvited = makeAesonLensMb "invited" oRest
+
+evMaybeAttending :: Lens' Object (Maybe Collection)
+evMaybeAttending = makeAesonLensMb "maybeAttending" oRest
+
+evNotAttendedBy :: Lens' Object (Maybe Collection)
+evNotAttendedBy = makeAesonLensMb "notAttendedBy" oRest
+
+evNotAttending :: Lens' Object (Maybe Collection)
+evNotAttending = makeAesonLensMb "notAttending" oRest
+
+evStartTime :: Lens' Object (Maybe DateTime)
+evStartTime = makeAesonLensMb "startTime" oRest
+
+-- issue
+
+isTypes :: Lens' Object (Maybe [Text])
+isTypes = makeAesonLensMb "types" oRest
+
+-- permission
+
+pmScope :: Lens' Object (Maybe Object)
+pmScope = makeAesonLensMb "scope" oRest
+
+pmActions :: Lens' Object (Maybe [Text])
+pmActions = makeAesonLensMb "actions" oRest
+
+-- place
+
+plPosition :: Lens' Object (Maybe PlacePosition)
+plPosition = makeAesonLensMb "position" oRest
+
+plAddress :: Lens' Object (Maybe PlaceAddress)
+plAddress = makeAesonLensMb "address" oRest
+
+data PlacePosition = PPO { fromPPO :: Aeson.Object } deriving (Eq, Show)
+
+instance FromJSON PlacePosition where
+  parseJSON (Aeson.Object o)
+    |    HM.member "altitude" o
+      && HM.member "latitude" o
+      && HM.member "longitude" o = return (PPO o)
+    | otherwise = fail "..."
+  parseJSON _ = fail "..."
+
+instance ToJSON PlacePosition where
+  toJSON = Aeson.Object . fromPPO
+
+data PlaceAddress = PAO { fromPAO :: Aeson.Object } deriving (Eq, Show)
+
+instance FromJSON PlaceAddress where
+  parseJSON (Aeson.Object o)
+    |    HM.member "formatted" o
+      && HM.member "streetAddress" o
+      && HM.member "locality" o
+      && HM.member "region" o
+      && HM.member "postalCode" o
+      && HM.member "country" o = return (PAO o)
+    | otherwise = fail "..."
+  parseJSON _ = fail "..."
+
+instance ToJSON PlaceAddress where
+  toJSON = Aeson.Object . fromPAO
+
+-- role/group
+
+rlMembers :: Lens' Object (Maybe [Object])
+rlMembers = makeAesonLensMb "members" oRest
+
+-- Task
+
+tsActor :: Lens' Object (Maybe Object)
+tsActor = makeAesonLensMb "actor" oRest
+
+tsBy :: Lens' Object (Maybe DateTime)
+tsBy = makeAesonLensMb "by" oRest
+
+tsObject :: Lens' Object (Maybe Object)
+tsObject = makeAesonLensMb "object" oRest
+
+tsPrerequisites :: Lens' Object (Maybe [Object])
+tsPrerequisites = makeAesonLensMb "prerequisites" oRest
+
+tsRequired :: Lens' Object (Maybe Bool)
+tsRequired = makeAesonLensMb "required" oRest
+
+tsSupersedes :: Lens' Object (Maybe [Object])
+tsSupersedes = makeAesonLensMb "supersedes" oRest
+
+tsVerb :: Lens' Object (Maybe SchemaVerb)
+tsVerb = makeAesonLensMb "verb" oRest
+
+-- extra properties
+
+acContext :: Lens' Activity (Maybe Object)
+acContext = makeAesonLensMb "context" acRest
+
+getLocation :: Lens' a Aeson.Object -> Lens' a (Maybe Object)
+getLocation = makeAesonLensMb "location"
+
+oMood :: Lens' Object (Maybe Mood)
+oMood = makeAesonLensMb "mood" oRest
+
+oRating :: Lens' Object (Maybe Double)
+oRating = makeAesonLensMb "rating" oRest
+
+acResult :: Lens' Activity (Maybe Object)
+acResult = makeAesonLensMb "result" acRest
+
+getSource :: Lens' a Aeson.Object -> Lens' a (Maybe Object)
+getSource = makeAesonLensMb "source"
+
+getStartTime :: Lens' a Aeson.Object -> Lens' a (Maybe Text)
+getStartTime = makeAesonLensMb "startTime"
+
+getEndTime :: Lens' a Aeson.Object -> Lens' a (Maybe Text)
+getEndTime = makeAesonLensMb "endTime"
+
+-- mood
+
+data Mood = Mood { fromMood :: Aeson.Object } deriving (Eq, Show)
+
+instance FromJSON Mood where
+  parseJSON (Aeson.Object o)
+    |    HM.member "displayName" o
+      && HM.member "image" o = return (Mood o)
+    | otherwise = fail "..."
+  parseJSON _ = fail "..."
+
+instance ToJSON Mood where
+  toJSON = Aeson.Object . fromMood
+
+moodRest :: Lens' Mood Aeson.Object
+moodRest = makeLens fromMood (\ o' m -> m { fromMood = o' })
+
+moodDisplayName :: Lens' Mood Text
+moodDisplayName = makeAesonLens "displayName" moodRest
+
+moodImage :: Lens' Mood MediaLink
+moodImage = makeAesonLens "image" moodRest

Codec/ActivityStream/LensInternal.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Codec.ActivityStream.LensInternal where
+
+import           Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.Maybe (fromJust)
+import           Data.Text (Text)
+
+-- This way, we don't have to import lens... but we can still export lenses!
+newtype Const a b = Const { fromConst :: a }
+instance Functor (Const a) where fmap f (Const x) = Const x
+
+-- We need these to write get and set
+newtype Id a = Id { fromId :: a }
+instance Functor Id where fmap f (Id x) = Id (f x)
+
+-- | This is the same type alias as in @Control.Lens@, and so can be used
+--   anywhere lenses are needed.
+type Lens' a b = forall f. Functor f => (b -> f b) -> (a -> f a)
+
+get :: Lens' a b -> a -> b
+get lens a = fromConst (lens Const a)
+
+set :: Lens' a b -> b -> a -> a
+set lens x a = fromId (lens (const Id x) a)
+
+makeLens :: (a -> b) -> (b -> a -> a) -> Lens' a b
+makeLens get set f a = (`set` a) `fmap` f (get a)
+
+fromJSON' :: FromJSON a => Aeson.Value -> Maybe a
+fromJSON' v = case fromJSON v of
+  Success a -> Just a
+  Error _   -> Nothing
+
+-- Create a lens into an Aeson object wrapper that takes and
+-- returns a Maybe value
+makeAesonLensMb :: (FromJSON v, ToJSON v)
+                => Text -> Lens' c Aeson.Object -> Lens' c (Maybe v)
+makeAesonLensMb key fromObj = fromObj . lens
+  where lens = makeLens
+                 (\ o -> HM.lookup key o >>= fromJSON')
+                 (\case Just v  -> HM.insert key (toJSON v)
+                        Nothing -> HM.delete key)
+
+
+-- Create a lens into an Aeson object wrapper
+makeAesonLens :: (FromJSON v, ToJSON v)
+              => Text -> Lens' c Aeson.Object -> Lens' c v
+makeAesonLens key fromObj = fromObj . lens
+  where lens = makeLens
+                 (\ o -> fromJust (HM.lookup key o >>= fromJSON'))
+                 (\ v o -> HM.insert key (toJSON v) o)

Codec/ActivityStream/Schema.hs

@@ -11,95 +11,109 @@ import Codec.ActivityStream.Internal
 import Codec.ActivityStream.Representation
 
 data SchemaVerb
-  = Accept
-  | Access
-  | Acknowledge
-  | Add
-  | Agree
-  | Append
-  | Approve
-  | Archive
-  | Assign
-  | At
-  | Attach
-  | Attend
-  | Author
-  | Authorize
-  | Borrow
-  | Build
-  | Cancel
-  | Close
-  | Complete
-  | Confirm
-  | Consume
-  | Checkin
-  | Create
-  | Delete
-  | Deliver
-  | Deny
-  | Disagree
-  | Dislike
-  | Experience
-  | Favorite
-  | Find
-  | FlagAsInappropriate
-  | Follow
-  | Give
-  | Host
-  | Ignore
-  | Insert
-  | Install
-  | Interact
-  | Invite
-  | Join
-  | Leave
-  | Like
-  | Listen
-  | Lose
-  | MakeFriend
-  | Open
-  | Play
-  | Post
-  | Present
-  | Purchase
-  | Qualify
-  | Read
-  | Receive
-  | Reject
-  | Remove
-  | RemoveFriend
-  | Replace
-  | Request
-  | RequestFriend
-  | Resolve
-  | Return
-  | Retract
-  | RsvpMaybe
-  | RsvpNo
-  | RsvpYes
-  | Satisfy
-  | Save
-  | Schedule
-  | Search
-  | Sell
-  | Send
-  | Share
-  | Sponsor
-  | Start
-  | StopFollowing
-  | Submit
-  | Tag
-  | Terminate
-  | Tie
-  | Unfavorite
-  | Unlike
-  | Unsatisfy
-  | Unsave
-  | Unshare
-  | Update
-  | Use
-  | Watch
-  | Win
+  = Accept -- ^ Indicates that that the actor has accepted the object.
+           --   For instance, a person accepting an award, or accepting
+           -- an assignment.
+  | Access -- ^ Indicates that the actor has accessed the object. For
+           --   instance, a person accessing a room, or accessing a file.
+  | Acknowledge -- ^ Indicates that the actor has acknowledged the object.
+                --   This effectively signals that the actor is aware of the
+                --   object's existence.
+  | Add -- ^ Indicates that the actor has added the object to the target.
+        --   For instance, adding a photo to an album.
+  | Agree -- ^ Indicates that the actor agrees with the object. For example,
+          --   a person agreeing with an argument, or expressing agreement
+          --   with a particular issue.
+  | Append -- ^ Indicates that the actor has appended the object to the
+           --   target. For instance, a person appending a new record
+           --   to a database.
+  | Approve -- ^ Indicates that the actor has approved the object. For
+            --   instance, a manager might approve a travel request.
+  | Archive -- ^ Indicates that the actor has archived the object.
+  | Assign -- ^ Indicates that the actor has assigned the object to the target.
+  | At -- ^ Indicates that the actor is currently located at the object.
+       --   For instance, a person being at a specific physical location.
+  | Attach -- ^ Indicates that the actor has attached the object to the
+           --   target. For instance, a person attaching a file to a wiki
+           --   page or an email.
+  | Attend -- ^
+  | Author -- ^
+  | Authorize -- ^
+  | Borrow -- ^
+  | Build -- ^
+  | Cancel -- ^
+  | Close -- ^
+  | Complete -- ^
+  | Confirm -- ^
+  | Consume -- ^
+  | Checkin -- ^
+  | Create -- ^
+  | Delete -- ^
+  | Deliver -- ^
+  | Deny -- ^
+  | Disagree -- ^
+  | Dislike -- ^
+  | Experience -- ^
+  | Favorite -- ^
+  | Find -- ^
+  | FlagAsInappropriate -- ^
+  | Follow -- ^
+  | Give -- ^
+  | Host -- ^
+  | Ignore -- ^
+  | Insert -- ^
+  | Install -- ^
+  | Interact -- ^
+  | Invite -- ^
+  | Join -- ^
+  | Leave -- ^
+  | Like -- ^
+  | Listen -- ^
+  | Lose -- ^
+  | MakeFriend -- ^
+  | Open -- ^
+  | Play -- ^
+  | Post -- ^
+  | Present -- ^
+  | Purchase -- ^
+  | Qualify -- ^
+  | Read -- ^
+  | Receive -- ^
+  | Reject -- ^
+  | Remove -- ^
+  | RemoveFriend -- ^
+  | Replace -- ^
+  | Request -- ^
+  | RequestFriend -- ^
+  | Resolve -- ^
+  | Return -- ^
+  | Retract -- ^
+  | RsvpMaybe -- ^
+  | RsvpNo -- ^
+  | RsvpYes -- ^
+  | Satisfy -- ^
+  | Save -- ^
+  | Schedule -- ^
+  | Search -- ^
+  | Sell -- ^
+  | Send -- ^
+  | Share -- ^
+  | Sponsor -- ^
+  | Start -- ^
+  | StopFollowing -- ^
+  | Submit -- ^
+  | Tag -- ^
+  | Terminate -- ^
+  | Tie -- ^
+  | Unfavorite -- ^
+  | Unlike -- ^
+  | Unsatisfy -- ^
+  | Unsave -- ^
+  | Unshare -- ^
+  | Update -- ^
+  | Use -- ^
+  | Watch -- ^
+  | Win -- ^ foo
     deriving (Eq, Show, Read)
 
 deriveJSON (commonOptsCC "") ''SchemaVerb

activitystreams-aeson.cabal

@@ -17,6 +17,7 @@ cabal-version:       >=1.10
 
 library
   exposed-modules:     Codec.ActivityStream.Dynamic,
+                       Codec.ActivityStream.DynamicSchema,
                        Codec.ActivityStream.Representation,
                        Codec.ActivityStream.Schema,
                        Codec.ActivityStream