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.

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

Build with 9.8 #25

Merged
merged 1 commit into from
Oct 2, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
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
111 changes: 53 additions & 58 deletions tutorial/Tutorial.md
Original file line number Diff line number Diff line change
Expand Up @@ -53,6 +53,9 @@ data Qsimple g = Qsimple
, _q_latestPostId :: GrpMap () g -- ^ morally a "bool"; for if the maxPost Id is being requested.
} deriving (Eq, Ord, Show, Read)

newtype GrpMap k v = GrpMap { unGrpMap :: Map k v } deriving (Eq, Ord, Show, Read)
type role GrpMap nominal nominal

```

And the corresponding result type. Note that we have the same set of fields occur in both.
Expand All @@ -73,13 +76,45 @@ have queries, and one of them "goes away", then we can either add the remaining
have. The latter is almost always quicker.

```haskell

instance (Eq g, Monoid g) => Semigroup (Qsimple g) where Qsimple x y <> Qsimple x' y' = Qsimple (x <> x') (y <> y')
instance (Eq g, Monoid g) => Monoid (Qsimple g) where mempty = Qsimple mempty mempty
instance (Eq g, Group g) => Group (Qsimple g) where negateG (Qsimple x y) = Qsimple (negateG x) (negateG y)
instance (Eq g, Monoid g, Commutative g) => Commutative (Qsimple g)
instance GrpFunctor Qsimple where mapG f (Qsimple x y) = Qsimple (mapG f x) (mapG f y)

class (forall g. (Eq g, Group g) => Group (f g)) => GrpFunctor f where
mapG :: (Eq b, Group b) => (a -> b) -> f a -> f b

instance (Monoid g, Eq g, Ord k) => Semigroup (GrpMap k g) where
GrpMap xs <> GrpMap ys = GrpMap $ Map.merge id id (Map.zipWithMaybeMatched $ const $ liftNonZero (<>)) xs ys


instance (Monoid g, Eq g, Ord k) => Monoid (GrpMap k g) where
mempty = GrpMap Map.empty
mappend = (<>)

instance (Group g, Eq g, Ord k) => Group (GrpMap k g) where
negateG (GrpMap xs) = GrpMap $ fmap negateG xs
GrpMap xs ~~ GrpMap ys = GrpMap $ Map.merge id (Map.mapMissing $ const $ negateG) (Map.zipWithMaybeMatched $ const $ liftNonZero (~~)) xs ys

liftNonZero :: (Monoid a, Eq a) => (a -> a -> a) -> a -> a -> Maybe a
liftNonZero f x y = if (xy /= mempty)
then Just x
else Nothing
where xy = f x y

-- distributive functors can still be groups.
instance GrpFunctor ((->) r) where mapG = fmap
instance GrpFunctor Proxy where mapG = fmap
instance GrpFunctor Identity where mapG = fmap

instance Ord k => GrpFunctor (GrpMap k) where
mapG f (GrpMap xs) = GrpMap $ Map.mapMaybe (\x ->
let fx = f x
in if fx /= mempty
then Just fx
else Nothing) xs

```

MonadQuery Also requires that QueryResult be a monoid; this reflects the idea
Expand Down Expand Up @@ -125,7 +160,7 @@ by examining the corresponding field.

```haskell

watchPost
watchPost
:: ( MonadQuery t (Qsimple SelectedCount) m
, QueryResult (Qsimple SelectedCount) ~ Rsimple
, Reflex t
Expand Down Expand Up @@ -186,6 +221,17 @@ displayPost postId = do
Nothing -> text "Post Not Found"
Just dPost -> dynText dPost

-- To avoid requiring reflex-dom, we stub out a few functions that you'd normally get from reflex-dom-core.
type Widget t m = (NotReady t m, Adjustable t m, PostBuild t m)

dyn_ :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m ()
dyn_ = void . networkView

text :: Monad m => Text -> m ()
text _ = pure ()

dynText :: Monad m => Dynamic t Text -> m ()
dynText _ = pure ()
```

We can try to improve the situation in essentially all of
Expand Down Expand Up @@ -239,6 +285,11 @@ boilerplate; there's a small amount of TH to derive GCompare and all of the
remaining instances follow from the view types in vessel:

```haskell
deriveArgDict ''Qvessel
deriveJSONGADT ''Qvessel
deriveGEq ''Qvessel
deriveGCompare ''Qvessel
deriveGShow ''Qvessel

viewPost :: (MonadQuery t (Vessel Qvessel (Const SelectedCount)) m, Reflex t, Monad m)
=> Dynamic t PostId -> m (Dynamic t (Maybe (Maybe Post)))
Expand All @@ -255,19 +306,6 @@ other types "right".
***

```haskell

-- To avoid requiring reflex-dom, we stub out a few functions that you'd normally get from reflex-dom-core.
type Widget t m = (NotReady t m, Adjustable t m, PostBuild t m)

dyn_ :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m ()
dyn_ = void . networkView

text :: Monad m => Text -> m ()
text _ = pure ()

dynText :: Monad m => Dynamic t Text -> m ()
dynText _ = pure ()

positive :: forall x. (Monoid x, Ord x) => x -> SelectedCount
positive x
| x > mempty = 1
Expand Down Expand Up @@ -319,47 +357,4 @@ readShowLatestPost = dischargeMonadQuery promtForIt displayLatestPost
promtForIt q = liftIO $ do
print q
readLn

-- annoying stuff that needs to exist but doesn't.
newtype GrpMap k v = GrpMap { unGrpMap :: Map k v } deriving (Eq, Ord, Show, Read)
type role GrpMap nominal nominal

liftNonZero :: (Monoid a, Eq a) => (a -> a -> a) -> a -> a -> Maybe a
liftNonZero f x y = if (xy /= mempty)
then Just x
else Nothing
where xy = f x y

instance (Monoid g, Eq g, Ord k) => Semigroup (GrpMap k g) where
GrpMap xs <> GrpMap ys = GrpMap $ Map.merge id id (Map.zipWithMaybeMatched $ const $ liftNonZero (<>)) xs ys

instance (Monoid g, Eq g, Ord k) => Monoid (GrpMap k g) where
mempty = GrpMap Map.empty
mappend = (<>)

instance (Group g, Eq g, Ord k) => Group (GrpMap k g) where
negateG (GrpMap xs) = GrpMap $ fmap negateG xs
GrpMap xs ~~ GrpMap ys = GrpMap $ Map.merge id (Map.mapMissing $ const $ negateG) (Map.zipWithMaybeMatched $ const $ liftNonZero (~~)) xs ys

class (forall g. (Eq g, Group g) => Group (f g)) => GrpFunctor f where
mapG :: (Eq b, Group b) => (a -> b) -> f a -> f b

-- distributive functors can still be groups.
instance GrpFunctor ((->) r) where mapG = fmap
instance GrpFunctor Proxy where mapG = fmap
instance GrpFunctor Identity where mapG = fmap

instance Ord k => GrpFunctor (GrpMap k) where
mapG f (GrpMap xs) = GrpMap $ Map.mapMaybe (\x ->
let fx = f x
in if fx /= mempty
then Just fx
else Nothing) xs

deriveArgDict ''Qvessel
deriveJSONGADT ''Qvessel
deriveGEq ''Qvessel
deriveGCompare ''Qvessel
deriveGShow ''Qvessel

```
10 changes: 5 additions & 5 deletions vessel.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -50,10 +50,10 @@ library
UndecidableInstances

build-depends:
aeson >=1.4 && <2.2
, base >=4.9 && <4.17
aeson >=1.4 && <2.3
, base >=4.9 && <4.20
, base-orphans ^>=0.8.5
, bifunctors ^>=5.5
, bifunctors >=5.5 && <5.7
, commutative-semigroups ^>=0.1
, constraints >=0.10 && <0.15
, constraints-extras ^>=0.4
Expand All @@ -63,11 +63,11 @@ library
, dependent-sum ^>=0.7
, dependent-sum-aeson-orphans ^>=0.3.1
, monoidal-containers ^>=0.6
, mtl ^>=2.2
, mtl >=2.2 && <2.4
, patch ^>=0.0.7.0
, reflex >=0.6.4 && <1
, semialign >=1
, these >=1 && <1.2
, these >=1 && <1.3
, witherable >=0.2 && <0.5

hs-source-dirs: src
Expand Down
Loading