ilyakooo0/roboservant
1
0
Fork 0
mirror of https://github.com/ilyakooo0/roboservant.git synced 2024-09-11 08:05:47 +03:00
Code Issues Packages Projects Releases Wiki Activity

some renaming

Browse Source
This commit is contained in:
Mark Wotton 2020-11-22 10:39:23 -05:00
parent 2498df9cd0
commit 67d88d2ef5
2 changed files with 31 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Roboservant/Types/Breakdown.hs
View File

@ -2,8 +2,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
@ -22,6 +22,7 @@ import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Typeable (TypeRep, Typeable, typeRep)
import GHC.Generics(Generic)
data Provenance
= Provenance TypeRep Int
@ -35,9 +36,18 @@ class Typeable x => BuildFrom x where
-- | Can't be built up from parts
newtype Atomic x = Atomic x
newtype Atom x = Atom { unAtom :: x }
instance Typeable x => BuildFrom (Atomic x) where
-- | can be broken down and built up from generic pieces
newtype Compound x = Compound { unCompound :: x }
instance (Typeable x, Generic x) => BuildFrom (Compound x) where
buildFrom = error "buildfrom"
instance (Typeable x, Generic x) => Breakdown (Compound x) where
breakdown = error "breakdown"
instance Typeable x => BuildFrom (Atom x) where
buildFrom = Map.lookup (typeRep (Proxy @x))
@ -53,13 +63,13 @@ promisedDyn :: Typeable a => Dynamic -> a
promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
-- instance BuildFrom Bool
deriving via (Atomic Bool) instance BuildFrom Bool
deriving via (Atom Bool) instance BuildFrom Bool
instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
buildFrom dict = Just $ fmap toDyn <$> options
where options :: NonEmpty ([Provenance], Maybe x)
options = ([],Nothing) :|
(maybe [] NEL.toList . fmap (fmap (fmap (Just . promisedDyn @x)))
(maybe [] (NEL.toList . (fmap (fmap (Just . promisedDyn @x))))
$ buildFrom @x dict)
class Breakdown x where
@ -67,14 +77,11 @@ class Breakdown x where
-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
-- breakdown = pure . toDyn
-- | Can't break it down any further -- stuck in your teeth, maybe.
newtype Chewy x = Chewy { unChew :: x }
instance Typeable a => Breakdown (Atom a) where
breakdown = pure . toDyn . unAtom
instance Typeable a => Breakdown (Chewy a) where
breakdown = pure . toDyn . unChew
deriving via (Chewy ()) instance Breakdown ()
deriving via (Chewy Int) instance Breakdown Int
deriving via (Atom ()) instance Breakdown ()
deriving via (Atom Int) instance Breakdown Int
--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]

23
test/Spec.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingVia #-}
@ -14,7 +13,7 @@ import qualified Post
import Data.Dynamic(toDyn)
import qualified Roboservant as RS
import Roboservant(Chewy,Breakdown, BuildFrom, Atomic)
import Roboservant(Breakdown, BuildFrom, Atom, Compound)
import Test.Hspec
import Test.Hspec.Core.Spec
import Data.Void
@ -78,24 +77,24 @@ spec = do
-- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
deriving via (Chewy Foo.Foo) instance Breakdown Foo.Foo
deriving via (Atomic Foo.Foo) instance BuildFrom Foo.Foo
deriving via (Atom Foo.Foo) instance Breakdown Foo.Foo
deriving via (Atom Foo.Foo) instance BuildFrom Foo.Foo
deriving via (Chewy Headers.Foo) instance Breakdown Headers.Foo
deriving via (Atomic Headers.Foo) instance BuildFrom Headers.Foo
deriving via (Atom Headers.Foo) instance Breakdown Headers.Foo
deriving via (Atom Headers.Foo) instance BuildFrom Headers.Foo
deriving via (Chewy Seeded.Seed) instance Breakdown Seeded.Seed
deriving via (Atomic Seeded.Seed) instance BuildFrom Seeded.Seed
deriving via (Atom Seeded.Seed) instance Breakdown Seeded.Seed
deriving via (Atom Seeded.Seed) instance BuildFrom Seeded.Seed
-- instance RS.BuildFrom Seeded.Seed
deriving via (Atomic Void) instance RS.BuildFrom Void
deriving via (Atom Void) instance RS.BuildFrom Void
deriving via (Atomic Post.FooPost) instance RS.BuildFrom Post.FooPost
deriving via (Chewy Post.FooPost) instance RS.Breakdown Post.FooPost
deriving via (Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
deriving via (Atom Post.FooPost) instance RS.Breakdown Post.FooPost
-- deriving via (Atomic Void) instance RS.BuildFrom Void
-- deriving via (Atom Void) instance RS.BuildFrom Void
-- instance RS.Breakdown Post.FooPost
-- instance RS.BuildFrom Post.FooPost