packages feed

stack-prism (empty) → 0.1

raw patch · 8 files changed

+425/−0 lines, 8 filesdep +basedep +profunctorsdep +taggedsetup-changed

Dependencies added: base, profunctors, tagged, template-haskell, transformers

Files

+ Data/StackPrism.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveFunctor #-}++module Data.StackPrism (++  -- * Stack prisms+  StackPrism, stackPrism, forward, backward, +  (:-)(..)++  ) where+++import Control.Applicative+import Data.Profunctor (Choice(..))+import Data.Profunctor.Unsafe+import Data.Functor.Identity+import Data.Monoid (First(..))+import Data.Tagged++-- | A stack prism is a bidirectional isomorphism that is partial in the backward direction.+-- These prisms are compatible with the @lens@ library.+--+-- This can be used to express constructor-deconstructor pairs. For example:+--+-- > nil :: StackPrism t ([a] :- t)+-- > nil = stackPrism f g+-- >   where+-- >     f        t  = [] :- t+-- >     g ([] :- t) = Just t+-- >     g _         = Nothing+-- >+-- > cons :: StackPrism (a :- [a] :- t) ([a] :- t)+-- > cons = stackPrism f g+-- >   where+-- >     f (x :- xs  :- t) = (x : xs) :- t+-- >     g ((x : xs) :- t) = Just (x :- xs :- t)+-- >     g _               = Nothing+--+-- Here ':-' can be read as \'cons\', forming a stack of values. For example,+-- @nil@ pushes @[]@ onto the stack; or, in the backward direction, tries to+-- remove @[]@ from the stack. Representing constructor-destructor pairs as+-- stack manipulators allows them to be composed more easily.+--+-- Modules "Data.StackPrism.Generic" and "Data.StackPrism.TH" offer generic ways of deriving @StackPrism@s for custom datatypes.++type StackPrism a b = forall p f. (Choice p, Applicative f) => p a (f a) -> p b (f b)++-- | Construct a prism.+stackPrism :: (a -> b) -> (b -> Maybe a) -> StackPrism a b+stackPrism f g = dimap (\b -> maybe (Left b) Right (g b)) (either pure (fmap f)) . right'++-- | Apply a prism in forward direction.+forward :: StackPrism a b -> a -> b+forward l = runIdentity #. unTagged #. l .# Tagged .# Identity++-- | Apply a prism in backward direction.+backward :: StackPrism a b -> b -> Maybe a+backward l = getFirst #. getConst #. l (Const #. First #. Just)+++-- | Heterogenous stack with a head and a tail. Or: an infix way to write @(,)@.+data h :- t = h :- t+  deriving (Eq, Show, Functor)+infixr 5 :-
+ Data/StackPrism/Generic.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}++module Data.StackPrism.Generic (StackPrisms, mkPrismList, PrismList(..), StackPrismLhs) where++import Data.StackPrism+import GHC.Generics+++-- | Derive a list of stack prisms, one for each constructor in the 'Generic' datatype @a@. The list is wrapped in the unary constructor @PrismList@. Within that constructor, the prisms are separated by the right-associative binary infix constructor @:&@. Finally, the individual prisms are wrapped in the unary constructor @I@. These constructors are all exported by this module, but no documentation is generated for them by Hackage.+--+-- As an example, here is how to define the prisms @nil@ and @cons@ for @[a]@, which is an instance of @Generic@:+--+-- > nil  :: StackPrism              t  ([a] :- t)+-- > cons :: StackPrism (a :- [a] :- t) ([a] :- t)+-- > PrismList (P nil :& P cons) = mkPrismList :: StackPrisms [a]+mkPrismList :: (Generic a, MkPrismList (Rep a)) => StackPrisms a+mkPrismList = mkPrismList' to (Just . from)++type StackPrisms a = PrismList (Rep a) a++data family PrismList (f :: * -> *) (a :: *)++class MkPrismList (f :: * -> *) where+  mkPrismList' :: (f p -> a) -> (a -> Maybe (f q)) -> PrismList f a++data instance PrismList (M1 D c f) a = PrismList (PrismList f a)++instance MkPrismList f => MkPrismList (M1 D c f) where+  mkPrismList' f' g' = PrismList (mkPrismList' (f' . M1) (fmap unM1 . g'))+++infixr :&++data instance PrismList (f :+: g) a = PrismList f a :& PrismList g a++instance (MkPrismList f, MkPrismList g) => MkPrismList (f :+: g) where+  mkPrismList' f' g' = f f' g' :& g f' g'+    where+      f :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PrismList f a+      f _f' _g' = mkPrismList' (\fp -> _f' (L1 fp)) (matchL _g')+      g :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PrismList g a+      g _f' _g' = mkPrismList' (\gp -> _f' (R1 gp)) (matchR _g')++      matchL :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (f q)+      matchL _g' a = case _g' a of+        Just (L1 f'') -> Just f''+        _ -> Nothing++      matchR :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (g q)+      matchR _g' a = case _g' a of+        Just (R1 g'') -> Just g''+        _ -> Nothing+++data instance PrismList (M1 C c f) a = P (forall t. StackPrism (StackPrismLhs f t) (a :- t))++instance MkStackPrism f => MkPrismList (M1 C c f) where+  mkPrismList' f' g' = P (stackPrism (f f') (g g'))+    where+      f :: forall a p t. (M1 C c f p -> a) -> StackPrismLhs f t -> a :- t+      f _f' lhs = mapHead (_f' . M1) (mkR lhs)+      g :: forall a p t. (a -> Maybe (M1 C c f p)) -> (a :- t) -> Maybe (StackPrismLhs f t)+      g _g' (a :- t) = fmap (mkL . (:- t) . unM1) (_g' a)+++-- Deriving types and conversions for single constructors++type family StackPrismLhs (f :: * -> *) (t :: *) :: *++class MkStackPrism (f :: * -> *) where+  mkR :: forall p t. StackPrismLhs f t -> (f p :- t)+  mkL :: forall p t. (f p :- t) -> StackPrismLhs f t++type instance StackPrismLhs U1 t = t+instance MkStackPrism U1 where+  mkR t         = U1 :- t+  mkL (U1 :- t) = t++type instance StackPrismLhs (K1 i a) t = a :- t+instance MkStackPrism (K1 i a) where+  mkR (h :- t) = K1 h :- t+  mkL (K1 h :- t) = h :- t++type instance StackPrismLhs (M1 i c f) t = StackPrismLhs f t+instance MkStackPrism f => MkStackPrism (M1 i c f) where+  mkR = mapHead M1 . mkR+  mkL = mkL . mapHead unM1++type instance StackPrismLhs (f :*: g) t = StackPrismLhs f (StackPrismLhs g t)+instance (MkStackPrism f, MkStackPrism g) => MkStackPrism (f :*: g) where+  mkR t = (hf :*: hg) :- tg+    where+      hf :- tf = mkR t+      hg :- tg = mkR tf+  mkL ((hf :*: hg) :- t) = mkL (hf :- mkL (hg :- t))++++mapHead :: (a -> b) -> (a :- t) -> (b :- t)+mapHead f (h :- t) = f h :- t
+ Data/StackPrism/TH.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.StackPrism.TH (deriveStackPrisms, deriveStackPrismsWith, deriveStackPrismsFor) where++import Data.StackPrism+import Language.Haskell.TH+import Control.Applicative+import Control.Monad++-- | Derive stack prisms for a given datatype.+--+-- For example:+--+-- > deriveStackPrisms ''Maybe+--+-- will create+--+-- > _Just :: StackPrism (a :- t) (Maybe a :- t)+-- > _Nothing :: StackPrism t (Nothing :- t)+--+-- together with their implementations.+deriveStackPrisms :: Name -> Q [Dec]+deriveStackPrisms = deriveStackPrismsWith ('_':)++-- | Derive stack prisms given a function that derives variable names from constructor names.+deriveStackPrismsWith :: (String -> String) -> Name -> Q [Dec]+deriveStackPrismsWith nameFun = deriveStackPrismsWith' (const nameFun)++-- | Derive stack prisms given a list of variable names, one for each constructor.+deriveStackPrismsFor :: [String] -> Name -> Q [Dec]+deriveStackPrismsFor names = deriveStackPrismsWith' (\i _ -> names !! i)++deriveStackPrismsWith' :: (Int -> String -> String) -> Name -> Q [Dec]+deriveStackPrismsWith' nameFun name = do+  info <- reify name+  routers <-+    case info of+      TyConI (DataD _ _ tyArgs cons _)   ->+        mapM (deriveStackPrism name tyArgs (length cons /= 1)) cons+      TyConI (NewtypeD _ _ tyArgs con _) ->+        (:[]) <$> deriveStackPrism name tyArgs False con+      _ ->+        fail $ show name ++ " is not a datatype."+  return $ concat +    [ [ SigD nm typeF+      , ValD (VarP nm) (NormalB router) []+      ] +    | (i, (conNm, typeF, router)) <- zip [0..] routers+    , let nm = mkName (nameFun i (nameBase conNm))+    ]++deriveStackPrism :: Name -> [TyVarBndr] -> Bool -> Con -> Q (Name, Type, Exp)+deriveStackPrism resNm tyArgs matchWildcard con =+  case con of+    NormalC name tys -> go name (map snd tys)+    RecC name tys -> go name (map (\(_,_,ty) -> ty) tys)+    InfixC (_, tyl) name (_, tyr) -> go name [tyl, tyr]+    _ -> fail $ "Unsupported constructor " ++ show (conName con)+  where+    go name tys = do+      stackPrismE <- [| stackPrism |]+      stackPrismCon <- deriveConstructor name tys+      stackPrismDes <- deriveDestructor matchWildcard name tys+      tNm <- newName "t"+      let t = VarT tNm+      let fromType = foldr (-:) t tys+      let toType = foldl (\t' (PlainTV ty) -> AppT t' (VarT ty)) (ConT resNm) tyArgs -: t+      return +        $ ( name+          , ForallT (PlainTV tNm:tyArgs) [] $ ConT (mkName "StackPrism") `AppT` fromType `AppT` toType+          , stackPrismE `AppE` stackPrismCon `AppE` stackPrismDes+          )++(-:) :: Type -> Type -> Type+l -: r = ConT (mkName ":-") `AppT` l `AppT` r++deriveConstructor :: Name -> [Type] -> Q Exp+deriveConstructor name tys = do+  -- Introduce some names+  t          <- newName "t"+  fieldNames <- replicateM (length tys) (newName "a")++  let cons = mkName ":-"+  let pat = foldr (\f fs -> UInfixP (VarP f) cons fs) (VarP t) fieldNames+  let applyCon = foldl (\f x -> f `AppE` VarE x) (ConE name) fieldNames+  let body = UInfixE applyCon (ConE cons) (VarE t)++  return $ LamE [pat] body+++deriveDestructor :: Bool -> Name -> [Type] -> Q Exp+deriveDestructor matchWildcard name tys = do+  -- Introduce some names+  r          <- newName "r"+  fieldNames <- replicateM (length tys) (newName "a")++  -- Figure out the names of some constructors+  ConE just  <- [| Just |]+  ConE cons  <- [| (:-) |]+  nothing    <- [| Nothing |]++  let conPat   = ConP name (map VarP fieldNames)+  let okBody   = ConE just `AppE`+                  foldr+                    (\h t -> UInfixE (VarE h) (ConE cons) t)+                    (VarE r)+                    fieldNames+  let okCase   = Match (UInfixP conPat cons (VarP r)) (NormalB okBody) []+  let failCase = Match WildP (NormalB nothing) []+  let allCases =+        if matchWildcard+              then [okCase, failCase]+              else [okCase]++  return $ LamCaseE allCases+++-- Retrieve the name of a constructor.+conName :: Con -> Name+conName con =+  case con of+    NormalC name _  -> name+    RecC name _     -> name+    InfixC _ name _ -> name+    ForallC _ _ con' -> conName con'
+ ExampleGeneric.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveGeneric #-}++module Example where++import Data.StackPrism+import Data.StackPrism.Generic++import GHC.Generics+++data Person = Person+  { name     :: String+  , gender   :: Gender+  , age      :: Int+  , location :: Coords+  } deriving (Eq, Show, Generic)++data Gender = Male | Female+  deriving (Eq, Show, Generic)++data Coords = Coords { lat :: Float, lng :: Float }+  deriving (Eq, Show, Generic)++-- The types in the first type parameter match those of the corresponding constructor's fields.+person :: StackPrism (String :- Gender :- Int :- Coords :- t) (Person :- t)+male   :: StackPrism t (Gender :- t)+female :: StackPrism t (Gender :- t)+coords :: StackPrism (Float :- Float :- t) (Coords :- t)++PrismList (P person)           = mkPrismList :: StackPrisms Person+PrismList (P male :& P female) = mkPrismList :: StackPrisms Gender+PrismList (P coords)           = mkPrismList :: StackPrisms Coords+++false, true :: StackPrism t (Bool :- t)+PrismList (P false :& P true) = mkPrismList :: StackPrisms Bool++nil  :: StackPrism              t  ([a] :- t)+cons :: StackPrism (a :- [a] :- t) ([a] :- t)+PrismList (P nil :& P cons) = mkPrismList :: StackPrisms [a]
+ ExampleTH.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++module Example where++import Data.StackPrism+import Data.StackPrism.TH+++data Person = Person+  { name     :: String+  , gender   :: Gender+  , age      :: Int+  , location :: Coords+  } deriving (Eq, Show)++data Gender = Male | Female+  deriving (Eq, Show)++data Coords = Coords { lat :: Float, lng :: Float }+  deriving (Eq, Show)++deriveStackPrisms ''Person+deriveStackPrisms ''Gender+deriveStackPrisms ''Coords
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2013, Martijn van Steenbergen+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 the author nor the+      names of his contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 <copyright holder> 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ stack-prism.cabal view
@@ -0,0 +1,37 @@+Name:           stack-prism+Version:        0.1+Synopsis:       Stack prisms+Description:    Haskell lens prisms that use stack types+++Author:         Martijn van Steenbergen, Sjoerd Visscher+Maintainer:     martijn@van.steenbergen.nl+Stability:      Experimental+Copyright:      Some Rights Reserved (CC) 2014 Martijn van Steenbergen+Homepage:       https://github.com/MedeaMelana/stack-prism+Bug-reports:    https://github.com/MedeaMelana/stack-prism/issues+++Cabal-Version:  >= 1.6+License:        BSD3+License-file:   LICENSE+Category:       Data+Build-type:     Simple++extra-source-files:+  ExampleGeneric.hs+  ExampleTH.hs++Library+  Exposed-Modules:  Data.StackPrism,+                    Data.StackPrism.TH,+                    Data.StackPrism.Generic+  Build-Depends:    base >= 3.0 && < 5,+                    profunctors >= 4.0 && < 5,+                    tagged >= 0.4.4 && < 1,+                    transformers >= 0.2 && < 0.5,+                    template-haskell >= 2.8 && < 2.10++Source-Repository head+  Type:         git+  Location:     https://github.com/MedeaMelana/stack-prism