module Music.Time.Meta (
AttributeClass,
TAttributeClass,
Attribute,
wrapAttr,
wrapTAttr,
unwrapAttr,
Meta,
wrapMeta,
wrapTMeta,
unwrapMeta,
HasMeta(..),
getMeta,
mapMeta,
setMeta,
metaTypes,
applyMeta,
setMetaAttr,
setMetaTAttr,
preserveMeta,
AddMeta,
annotated,
unannotated,
unsafeAnnotated
) where
import Control.Applicative
import Control.Comonad
import Control.Lens hiding (transform)
import Control.Monad.Plus
import Data.Foldable (Foldable)
import qualified Data.Foldable as F
import Data.Functor.Adjunction (unzipR)
import Data.Functor.Couple
import Data.Functor.Rep
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String
import Data.Typeable
import Music.Time.Internal.Util
import Music.Time.Juxtapose
type AttributeClass a = (Typeable a, Monoid a, Semigroup a)
type TAttributeClass a = (Transformable a, AttributeClass a)
data Attribute :: * where
Attribute :: AttributeClass a => a -> Attribute
TAttribute :: TAttributeClass a => a -> Attribute
wrapAttr :: AttributeClass a => a -> Attribute
wrapAttr = Attribute
wrapTAttr :: TAttributeClass a => a -> Attribute
wrapTAttr = TAttribute
unwrapAttr :: AttributeClass a => Attribute -> Maybe a
unwrapAttr (Attribute a) = cast a
unwrapAttr (TAttribute a) = cast a
instance Semigroup Attribute where
(Attribute a1) <> a2 = case unwrapAttr a2 of
Nothing -> error "Attribute.(<>) mismatch"
Just a2' -> Attribute (a1 <> a2')
(TAttribute a1) <> a2 = case unwrapAttr a2 of
Nothing -> error "Attribute.(<>) mismatch"
Just a2' -> TAttribute (a1 <> a2')
instance Transformable Attribute where
transform _ (Attribute a) = Attribute a
transform s (TAttribute a) = TAttribute (transform s a)
instance Reversible Attribute where
rev = id
newtype Meta = Meta { _getMeta :: Map String Attribute }
deriving (Transformable, Reversible)
instance Semigroup Meta where
Meta s1 <> Meta s2 = Meta $ Map.unionWith (<>) s1 s2
instance Monoid Meta where
mempty = Meta Map.empty
mappend = (<>)
wrapTMeta :: forall a. TAttributeClass a => a -> Meta
wrapTMeta a = Meta $ Map.singleton key $ wrapTAttr a
where
key = show $ typeOf (undefined :: a)
unwrapMeta :: forall a. AttributeClass a => Meta -> Maybe a
unwrapMeta (Meta s) = (unwrapAttr =<<) $ Map.lookup key s
where
key = show . typeOf $ (undefined :: a)
wrapMeta :: forall a. AttributeClass a => a -> Meta
wrapMeta a = Meta $ Map.singleton key $ wrapAttr a
where
key = show $ typeOf (undefined :: a)
class HasMeta a where
meta :: Lens' a Meta
instance Show Meta where
show _ = "{ meta }"
instance HasMeta Meta where
meta = ($)
instance HasMeta a => HasMeta (Maybe a) where
meta = lens viewM $ flip setM
where
viewM Nothing = mempty
viewM (Just x) = view meta x
setM m = fmap (set meta m)
instance HasMeta a => HasMeta (b, a) where
meta = _2 . meta
instance HasMeta a => HasMeta (Twain b a) where
meta = _Wrapped . meta
getMeta :: HasMeta a => a -> Meta
getMeta = view meta
setMeta :: HasMeta a => Meta -> a -> a
setMeta = set meta
mapMeta :: HasMeta a => (Meta -> Meta) -> a -> a
mapMeta = over meta
metaTypes :: HasMeta a => a -> [String]
metaTypes x = Map.keys $ _getMeta $ x^.meta
applyMeta :: HasMeta a => Meta -> a -> a
applyMeta m = over meta (<> m)
setMetaAttr :: (AttributeClass b, HasMeta a) => b -> a -> a
setMetaAttr a = applyMeta (wrapMeta a)
setMetaTAttr :: (TAttributeClass b, HasMeta a) => b -> a -> a
setMetaTAttr a = applyMeta (wrapTMeta a)
preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b
preserveMeta f x = let m = view meta x in set meta m (f x)
newtype AddMeta a = AddMeta { getAddMeta :: Meta `Twain` a }
deriving (Show, Functor, Foldable, Typeable, Applicative, Monad, Comonad,
Semigroup, Monoid, Num, Fractional, Floating, Enum, Bounded,
Integral, Real, RealFrac, Eq, Ord)
instance Wrapped (AddMeta a) where
type Unwrapped (AddMeta a) = Twain Meta a
_Wrapped' = iso getAddMeta AddMeta
instance Rewrapped (AddMeta a) (AddMeta b)
instance HasMeta (AddMeta a) where
meta = _Wrapped . _Wrapped . _1
instance Traversable AddMeta where
traverse = annotated
instance Transformable a => Transformable (AddMeta a) where
transform t = over meta (transform t) . over annotated (transform t)
instance Reversible a => Reversible (AddMeta a) where
rev = over meta rev . over annotated rev
instance Splittable a => Splittable (AddMeta a) where
split t = unzipR . fmap (split t)
instance HasPosition a => HasPosition (AddMeta a) where
_era = _era . extract
_position = _position . extract
instance HasDuration a => HasDuration (AddMeta a) where
_duration = _duration . extract
annotated :: Lens (AddMeta a) (AddMeta b) a b
annotated = unsafeAnnotated
unannotated :: Getter a (AddMeta a)
unannotated = from unsafeAnnotated
unsafeAnnotated :: Iso (AddMeta a) (AddMeta b) a b
unsafeAnnotated = _Wrapped . extracted
extracted :: (Applicative m, Comonad m) => Iso (m a) (m b) a b
extracted = iso extract pure
extractedRep :: (Representable m, w ~ Rep m, Monoid w) => Iso (m a) (m b) a b
extractedRep = iso extractRep pureRep