functor-friends (empty) → 0.1.0.0

raw patch · 8 files changed

+344/−0 lines, 8 filesdep +basedep +recursion-schemessetup-changed

Dependencies added: base, recursion-schemes

Files

• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• functor-friends.cabal +29/−0
• src/Data/Functor/Annotated.hs +60/−0
• src/Data/Functor/Decomposed.hs +23/−0
• src/Data/Functor/Holey.hs +63/−0
• src/Data/Functor/Tutorial.hs +136/−0

@@ -0,0 +1,30 @@+Copyright Matt Noonan (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 Matt Noonan 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.

@@ -0,0 +1,1 @@+# functor-friends

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

@@ -0,0 +1,29 @@+name:                functor-friends+version:             0.1.0.0+synopsis:            Friendly helpers for your recursion schemes.+description:         A library to assist with manipulating and modifying+                     types defined by fixpoints.+homepage:            https://github.com/matt-noonan/functor-friends#readme+license:             BSD3+license-file:        LICENSE+author:              Matt Noonan+maintainer:          matt.noonan@gmail.com+copyright:           (c) 2017 Matt Noonan+category:            Data Structures+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Data.Functor.Holey+                     , Data.Functor.Annotated+                     , Data.Functor.Decomposed+                     , Data.Functor.Tutorial+  build-depends:       base >= 4.7 && < 5+                     , recursion-schemes+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/matt-noonan/functor-friends

@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveFunctor, TypeFamilies, PatternSynonyms, RankNTypes #-}++module Data.Functor.Annotated+  ( -- * The @Annotated@ type family+    Annotated+    +    -- * Types+  , AnnotatedF(..)+    +    -- ** Patterns for hiding @Fix@+  , pattern Note++    -- * Utility functions+  , note+  , erase+  , foldMemo+    +  ) where++import Data.Functor.Foldable (Fix(..), fold, unfold)+import Data.Functor.Decomposed++-- | @AnnotatedF a f@ transforms the functor @f@ to add+-- @a@-valued annotations.++data AnnotatedF a f t+  = NoteF { note_  :: a+          , erase_ :: f t+          }+  deriving (Eq, Ord, Functor)++pattern Note a e = Fix (NoteF a e)++instance Decomposed (AnnotatedF a) where+  fmap1 f n = n { erase_ = f (erase_ n) }+  +-- | If @T@ is a type that is defined as a fixpoint, then+-- an @Annotated a T@ will be the type of "@T@s with an+-- @a@-valued annotation attached to each node".++type family   Annotated a f+type instance Annotated a (Fix f) = Fix (AnnotatedF a f)++-- | Extract the top-level annotation.++note :: Fix (AnnotatedF t f) -> t+note (Note t _) = t++-- | Discard the annotations.++erase :: Functor f => Fix (AnnotatedF t f) -> Fix f+erase = unfold (\(Note _ e) -> e)++-- | Fold a function over a data structure, storing the+-- sub-results as annotations.++foldMemo :: Functor f => (f t -> t) -> Fix f -> Fix (AnnotatedF t f)+foldMemo phi = fold phi'+  where+    phi' x = Note (phi $ fmap note x) x

@@ -0,0 +1,23 @@+{-# LANGUAGE RankNTypes #-}++module Data.Functor.Decomposed+  ( Decomposed(..)+  , natmap+  ) where++import Data.Functor.Foldable (Fix(..), unfix, unfold)++-- | A type class for types @d :: (* -> *) -> * -> *@ that+-- represent compositions of functors. For a functor @f :: * -> *@,+-- @d f t@ should look like some functor applied to the type @f t@,+-- and @fmap1@ is just @fmap@ for that functor.+class Decomposed d where+  fmap1 :: (f t -> g t) -> d f t -> d g t++-- | Given a natural transformation between functors, produce a+-- function between the fixpoints of those functors.+natmap :: (Functor f, Functor g)+       => (forall t. f t -> g t)+       -> Fix f+       -> Fix g+natmap f = unfold (f . unfix)

@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveFunctor, TypeFamilies, PatternSynonyms, RankNTypes #-}++module Data.Functor.Holey+  ( -- * The @Holey@ type family+    Holey+    +    -- * Types+  , HoleF(..)+    +    -- ** Patterns for hiding @Fix@+  , pattern Hole+  , pattern Existing++    -- * Utility functions+  , whole+  , plug+  , punch+    +  ) where++import Data.Functor.Foldable (Fix(..), unfix, fold, unfold)+import Data.Functor.Decomposed++-- | @HoleF f@ transforms the functor @f@ to add "holes".++data HoleF f t+  = HoleF           -- ^ A hole.+  | ExistingF (f t) -- ^ A normal value.+  deriving (Eq, Ord, Functor)++pattern Hole = Fix HoleF+pattern Existing e = Fix (ExistingF e)++instance Decomposed HoleF where+  fmap1 _ HoleF = HoleF+  fmap1 f (ExistingF e) = ExistingF (f e)++-- | If @T@ is a type that is defined as a fixpoint, then+-- a @Holey T@ will be the type of "@T@s with holes".++type family   Holey f+type instance Holey (Fix f) = Fix (HoleF f)++-- | Upgrade a value of type @T@ to a value of type+-- @T@-with-holes, without actually introducing any holes.++whole :: Functor f => Fix f -> Fix (HoleF f)+whole = unfold (ExistingF . unfix)++-- | Fill all holes in a data structure with the given value.++plug :: Functor f => Fix f -> Fix (HoleF f) -> Fix f+plug x = fold phi+  where+    phi HoleF = x+    phi (ExistingF e) = Fix e+  +-- | Replace any substructure matching the predicate with a hole.++punch :: Functor f => (Fix f -> Bool) -> Fix f -> Fix (HoleF f)+punch test = unfold phi+  where+    phi x@(Fix e) = if test x then HoleF else ExistingF e

@@ -0,0 +1,136 @@+{-# LANGUAGE LambdaCase, PatternSynonyms, DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module Data.Functor.Tutorial where++import Data.Functor.Holey+import Data.Functor.Annotated+import Data.Functor.Decomposed++import Data.Functor.Foldable ( Fix(..), fold, cata )++-- | An example AST type, as an F-algebra. This AST will be used+-- to demonstrate some tricks for composing new data types+-- while maintaining separation of concerns.+--+-- This approach was inspired by the @recursion-schemes@ library+-- and the "Data Types a la Carte" paper.++data AstF t+  = RealF    Double+  | ComplexF Double Double+  | VarF String+  | AddF t t+  | MulF t t+  | AbsF t+  deriving (Eq, Ord, Functor)++type Ast = Fix AstF++-- | Patterns to simplify the construction and destructuring of ASTs+pattern Add x y = Fix (AddF x y)+pattern Mul x y = Fix (MulF x y)+pattern Abs x   = Fix (AbsF x)+pattern Real x  = Fix (RealF x)+pattern Complex x y = Fix (ComplexF x y)+pattern Var x   = Fix (VarF x)++-- | A pretty-printing typeclass.+--+-- This demonstrates an approach to separation of concerns; the+-- pretty-printer for normal ASTs is implemented independently from+-- the pretty-printer for holes and the pretty-printer for annotations.+--+-- Although the implementations don't know about each other, they can+-- still be composed; as a result, a @Holey Ast@ knows how to print itself+-- using a mixture of the pretty-printer for @Ast@s and the pretty-printer+-- for @Hole@s.++class Pretty a where+  pretty :: a -> String++-- | Pretty-printer for fixpoints.+instance Pretty (f (Fix f)) => Pretty (Fix f) where+  pretty (Fix x) = pretty x++-- | Pretty-printer for ASTs.+instance Pretty t => Pretty (AstF t) where+  +  pretty = \case+        RealF d        -> show d+        ComplexF re im -> paren (show re ++ " + " ++ show im ++ "i")+        AddF x y       -> paren (pretty x ++ " + " ++ pretty y)+        MulF x y       -> paren (pretty x ++ " * " ++ pretty y)+        AbsF x         -> "|" ++ pretty x ++ "|"+        VarF v         -> v+    where+      paren x = "(" ++ x ++ ")"++-- | Pretty-printer for holes.+instance Pretty (f (Fix (HoleF f))) => Pretty (HoleF f (Fix (HoleF f))) where++  pretty HoleF         = "_"+  pretty (ExistingF x) = pretty x++-- | Pretty-printer for annotations.+instance (Pretty (f (Fix (AnnotatedF a f))), Show a) => Pretty (AnnotatedF a f (Fix (AnnotatedF a f))) where++  pretty (NoteF ann x) = pretty x ++ "{" ++ show ann ++ "}"+  +-- | A simple expression+expr1 :: Ast+expr1 = Abs (Add (Mul (Real 2) (Complex 0 1)) (Real 1))++-- | Another simple expression+expr2 :: Ast+expr2 = Add (Mul (Var "z") (Var "z")) (Mul (Real 3) (Var "z"))++-- | An expression-with-holes. Holes can be plugged with 'plug'.+--+-- λ> pretty expr3+-- "|(_ + 1.0)|"+--+-- λ> pretty (plug (Var "z") expr3)+--"|(z + 1.0)|"+--+-- λ> :t plug (Var "z") expr3+-- plug (Var "z") expr3 :: Fix AstF -- aka Ast++expr3 :: Holey Ast+expr3 = Existing (AbsF (Existing (AddF Hole (Existing (RealF 1)))))++-- | Real and Complex type tags+data Type = R | C deriving (Eq, Show)++-- | Annotate each subexpression with its type (real or complex).+--+-- λ> pretty expr1+-- "|((2.0 * (0.0 + 1.0i)) + 1.0)|"+--+-- λ> pretty (inferTypes expr1)+-- "|((2.0{R} * (0.0 + 1.0i){C}){C} + 1.0{R}){C}|{R}"++inferTypes :: Ast -> Annotated Type Ast+inferTypes = foldMemo typeOf+  where+    typeOf = \case+      AddF R R -> R+      MulF R R -> R+      AbsF _   -> R+      RealF _  -> R+      _        -> C++-- | Remove all real-valued subexpressions, leaving a 'Hole'+-- in their place.+--+-- λ> pretty expr2+-- "((z * z) + (3.0 * z))"+--+-- λ> pretty (unreal expr2)+-- "((z * z) + (_ * z))"++unreal :: Ast -> Holey Ast+unreal = eraseTypes . punch (\x -> note x == R) . inferTypes+  where+   eraseTypes = natmap (fmap1 erase_)+