Last active
August 20, 2018 11:58
-
-
Save danbornside/f3200a24b711553dc31d69054d43bdd2 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE ConstraintKinds #-} | |
| {-# LANGUAGE DeriveTraversable #-} | |
| {-# LANGUAGE FlexibleContexts #-} | |
| {-# LANGUAGE FlexibleInstances #-} | |
| {-# LANGUAGE FunctionalDependencies #-} | |
| {-# LANGUAGE GADTs #-} | |
| {-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
| {-# LANGUAGE InstanceSigs #-} | |
| {-# LANGUAGE LambdaCase #-} | |
| {-# LANGUAGE MultiParamTypeClasses #-} | |
| {-# LANGUAGE PolyKinds #-} | |
| {-# LANGUAGE Rank2Types #-} | |
| {-# LANGUAGE ScopedTypeVariables #-} | |
| {-# LANGUAGE StandaloneDeriving #-} | |
| {-# LANGUAGE TupleSections #-} | |
| {-# LANGUAGE TypeFamilies #-} | |
| {-# LANGUAGE TypeOperators #-} | |
| {-# LANGUAGE UndecidableInstances #-} | |
| module ViewSelector.Interval where | |
| import ViewSelector | |
| import Data.AppendIntervalMap | |
| import Data.Witherable | |
| import Data.Foldable (fold) | |
| -- TODO: this could be betterish | |
| import Data.Map.Monoidal (MonoidalMap) | |
| import Control.Lens.Indexed (FunctorWithIndex) | |
| import Control.Lens.Indexed (FoldableWithIndex) | |
| import Control.Lens.Indexed (TraversableWithIndex, itraverse) | |
| import Data.Constraint | |
| import Data.Semigroup(First(..), Option(..)) | |
| -- there's probably a way to do this without a gadt, but i seem to need 'names' | |
| -- for the two key types in the View. | |
| data IntervalSelector k e (v :: *) a where | |
| IntervalSelector :: AppendIntervalMap (ClosedInterval e) a -> IntervalSelector (ClosedInterval e) e v a | |
| instance Functor (IntervalSelector k e v) where | |
| fmap f (IntervalSelector xs) = IntervalSelector $ fmap f xs | |
| instance Foldable (IntervalSelector k e v) where | |
| foldMap f (IntervalSelector xs) = foldMap f xs | |
| instance Traversable (IntervalSelector k e v) where | |
| traverse f (IntervalSelector xs) = IntervalSelector <$> traverse f xs | |
| instance Ord e => Filterable (IntervalSelector k e v) where | |
| mapMaybe f (IntervalSelector xs) = IntervalSelector $ mapMaybe f xs | |
| instance (Ord e, Semigroup a) => Semigroup (IntervalSelector k e v a) where | |
| IntervalSelector xs <> IntervalSelector ys = IntervalSelector (xs <> ys) | |
| instance (k ~ ClosedInterval e, Ord e, Semigroup a) => Monoid (IntervalSelector k e v a) where | |
| mappend = (<>) | |
| mempty = IntervalSelector mempty | |
| instance (Ord e) => ViewSelector (IntervalSelector (ClosedInterval e) e v) where | |
| newtype View (IntervalSelector (ClosedInterval e) e v) a = IntervalMapView { unIntervalMapView :: MonoidalMap e (First v, a) } | |
| deriving (Show, Functor, Foldable, Traversable, Semigroup, Monoid) | |
| type ViewIndex (IntervalSelector (ClosedInterval e) e v) = e | |
| _viewMonoid = Sub Dict | |
| _viewSelectorSemiGrp = Sub Dict | |
| lookup k (IntervalSelector xs) = getOption $ fold $ fmap (Option . Just) $ containing xs k | |
| instance Filterable (View (IntervalSelector (ClosedInterval e) e v)) where | |
| mapMaybe f = IntervalMapView . mapMaybe (traverse f) . unIntervalMapView | |
| instance Witherable (View (IntervalSelector (ClosedInterval e) e v)) | |
| instance FunctorWithIndex e (View (IntervalSelector (ClosedInterval e) e v)) | |
| instance FoldableWithIndex e (View (IntervalSelector (ClosedInterval e) e v)) | |
| instance TraversableWithIndex e (View (IntervalSelector (ClosedInterval e) e v)) where | |
| itraverse f = fmap IntervalMapView . itraverse f' . unIntervalMapView | |
| where | |
| f' k (x, y) = (x,) <$> f k y | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment