servant-zeppelin (empty) → 0.1.0.0

raw patch · 6 files changed

+196/−0 lines, 6 filesdep +basedep +singletonssetup-changed

Dependencies added: base, singletons

Files

LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
servant-zeppelin.cabal +37/−0
src/Servant/Zeppelin.hs +8/−0
src/Servant/Zeppelin/Internal/Types.hs +118/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,1 @@+# servant-side-loaded

+ Setup.hs view

@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain

+ servant-zeppelin.cabal view

@@ -0,0 +1,37 @@+name:                servant-zeppelin+version:             0.1.0.0+homepage:            https://github.com/martyall/servant-zeppelin#readme+license:             BSD3+license-file:        LICENSE+author:              Martin Allen, Ben Weitzman+maintainer:          martin[dot]allen26[at]gmail.com+copyright:           2017 Martin Allen, Ben Weitzman+synopsis:            Types and definitions of servant-zeppelin combinators.+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Servant.Zeppelin+                     , Servant.Zeppelin.Internal.Types+  build-depends:       base >= 4.7 && < 5+                     , singletons+  default-language:    Haskell2010+  default-extensions:  GADTs+                     , KindSignatures+                     , FlexibleInstances+                     , PolyKinds+                     , DataKinds+                     , TypeOperators+                     , TypeFamilies+                     , TypeInType+                     , MultiParamTypeClasses+                     , ConstraintKinds+                     , FunctionalDependencies+                     , StandaloneDeriving++source-repository head+  type:     git+  location: https://github.com/martyall/servant-zeppelin

+ src/Servant/Zeppelin.hs view

@@ -0,0 +1,8 @@+module Servant.Zeppelin where++import           Data.Kind++-- | Combinator to indicate the availablity of side loaded data.+--+-- > "albums" :> Get '[JSON] Album :> SideLoad '[Person, [Photo]]+data SideLoad (fs :: [*])

+ src/Servant/Zeppelin/Internal/Types.hs view

@@ -0,0 +1,118 @@+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-}++module Servant.Zeppelin.Internal.Types+  ( DependencyList(..)+  , NamedDependency(..)+  , SideLoaded(..)+  , Inflatable(..)+  , HasDependencies(..)+  , AllSatisfy(..)+  , Inflatable'+  , Full'+  ) where++import           Data.Functor.Identity   (Identity)+import           Data.Kind+import           Data.Singletons.Prelude++--------------------------------------------------------------------------------+-- Dependency Lists+--------------------------------------------------------------------------------++-- | 'DependencyList' @m bs fs@ is a type representing a heterogeneous list parameterized+-- by @bs@ , which can be transformed into a hetergeneous list of type @fs@ in the context+-- provided by @m@.+data DependencyList :: (* -> *) -> [*] -> [*] -> * where+  NilDeps :: DependencyList m '[] '[]+  (:&:) :: b -> DependencyList m bs fs -> DependencyList m (b:bs) (f:fs)++infixr 5 :&:++instance AllSatisfy bs Show' => Show (DependencyList m bs fs) where+  show NilDeps    = "NilDeps"+  show (b :&: bs) = show b ++ " :&: " ++ show bs++instance AllSatisfy bs Eq' => Eq (DependencyList m bs fs) where+  NilDeps == NilDeps = True+  (b :&: bs) == (b' :&: bs') = b == b' && bs == bs'++-- | Labels for the objects created in the dependency mapping. Necessary for JSON instances.+--+-- > type instance NamedDependency Person = "person"+-- > type instance NamedDependency [Photo] = "photos"+--+type family NamedDependency a :: Symbol++-- | 'SideLoaded' @a deps@ represents a type @a@ with an hlist of its inflated dependencies.+data SideLoaded a (deps :: [*]) = SideLoaded a (DependencyList Identity deps deps)++deriving instance (Show a, Show (DependencyList Identity deps deps)) => Show (SideLoaded a deps)+deriving instance (Eq a, Eq (DependencyList Identity deps deps)) => Eq (SideLoaded a deps)++-- | Inflatable represents a type 'b' which can be expanded inside of a context 'm'.+--+-- > type PGMonad = ReaderT Connection (ExceptT QueryError IO)+-- >+-- > instance Inflatable PGMonad PersonId where+-- >   type Full PGMonad PersonId = Person+-- >   inflator = getPersonById++class Inflatable m base where+  type Full m base :: *+  inflator :: base -> m (Full m base)++-- | Anything can be expanded into itself in the trivial context.+instance Inflatable Identity base where+  type Full Identity base = base+  inflator = return++--------------------------------------------------------------------------------+-- HasDepedencies+--------------------------------------------------------------------------------++-- | Indicate that a type has dependencies, and supply the uninflated values.+--+-- > data Album =+-- >   Album { albumId     :: AlbumId+-- >         , albumArtist :: PersonId+-- >         , albumPhotos :: [PhotoId]+-- >         , albumTitle  :: Text+-- >         }+-- >+-- > instance HasDependencies PGMonad Album '[Person, [PhotoId]] where+-- >   getDependencies album = albumArtist album :&: albumPhotos album :&: NilDeps++class AllSatisfy bs (Inflatable' m) => HasDependencies m a bs | a -> bs, bs -> m where+  getDependencies :: a -> DependencyList m bs (Map (Full' m) bs)++--------------------------------------------------------------------------------+-- Type Families+--------------------------------------------------------------------------------++-- | All subjects must satisfy the test constraint.+type family AllSatisfy (subjects :: [k]) (test :: (k ~> Constraint)) :: Constraint where+  AllSatisfy '[] test = ()+  AllSatisfy (subj : rest) test = (Apply test subj, AllSatisfy rest test)++-- | Parially applied 'Inflatable' constraint.+data Inflatable' :: m -> (base ~> Constraint) where+  Inflatable' :: Inflatable' m base++type instance Apply (Inflatable' m) base = Inflatable m base++-- | Defunctionalized 'Full' type family to be used with 'Map'.+data Full' :: m -> (base ~> *) where+  Full' :: Full' m base++type instance Apply (Full' m) base = Full m base++data Eq' :: b ~> Constraint where+  Eq' :: Eq' b++type instance Apply Eq' b = Eq b++data Show' :: b ~> Constraint where+  Show' :: Show' b++type instance Apply Show' b = Show b