packages feed

functor-combo (empty) → 0.0.0

raw patch · 13 files changed

+1107/−0 lines, 13 filesdep +TypeComposedep +basedep +containerssetup-changed

Dependencies added: TypeCompose, base, containers, data-inttrie

Files

+ COPYING view
@@ -0,0 +1,25 @@+Copyright (c) 2009 Conal Elliott+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. The names of the authors may not be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.+
+ Makefile view
@@ -0,0 +1,1 @@+include ../cho-home-cabal-make.inc
+ README view
@@ -0,0 +1,11 @@+project-foo [1] is a template for a package, to make it easy to copy &+modify.  It uses cabal-make [2] for convenience.  It's even equipped with+a darcs repo.  Copy the directory ("cp -rp"), "darcs mv" and edit the+.cabal file, edit README and wikipage.tw, and "rm _darcs/prefs/*repo*".+Then add new content with "make check-add" and "make add-new".  "darcs+record" the changes.  When ready, do a "darcs put" or "make repo".++References:++[1] http://haskell.org/haskellwiki/project-foo+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ functor-combo.cabal view
@@ -0,0 +1,42 @@+Name:                functor-combo+Version:             0.0.0+Cabal-Version:       >= 1.2+Synopsis:            Functor combinators with tries & zippers+Category:            Data+Description:+  Simple functor combinators, their derivatives, and their use for tries+  Maybe split out derivatives and/or tries later.+  .+Author:              Conal Elliott+Maintainer:          conal@conal.net+Homepage:            http://haskell.org/haskellwiki/functor-combo+Copyright:           (c) 2010 by Conal Elliott+License:             BSD3+License-File:        COPYING+Stability:           experimental+build-type:          Simple++Package-Url:         http://code.haskell.org/~conal/code/functor-combo+-- Wait until Cabal 1.6 is more wide-spread and then add the following+-- in place of the Package-Url field and bump Cabal-Version to >= 1.6.+-- +-- Source-Repository head+--     type:         darcs+--     location:     http://code.haskell.org/~conal/code/functor-combo++Library+  hs-Source-Dirs:      src+  Extensions:+  Build-Depends:       base<5, TypeCompose >= 0.8, containers, data-inttrie+  Exposed-Modules:     +                       FunctorCombo.Functor+                       FunctorCombo.Derivative+                       FunctorCombo.Holey+                       FunctorCombo.DHoley+                       FunctorCombo.FixC+                       FunctorCombo.Regular+                       FunctorCombo.LocT+                       FunctorCombo.MemoTrie+  ghc-options:         -Wall++--  ghc-prof-options:    -prof -auto-all
+ src/FunctorCombo/DHoley.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeFamilies, TypeOperators, TupleSections #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.Holey+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Filling and extracting derivatives (one-hole contexts)+                                                         +-- Variation on Holey, integrating 'Der'+----------------------------------------------------------------------++module FunctorCombo.DHoley (Holey(..)) where++import Control.Arrow (first,second)++import FunctorCombo.Functor+++{--------------------------------------------------------------------+    Extraction+--------------------------------------------------------------------}++-- | Location, i.e., one-hole context and a value for the hole.+type Loc f a = (Der f a, a)++class Functor f => Holey f where+  type Der f :: * -> *                  -- ^ Derivative, i.e., one-hole context+  fill    :: Loc f a -> f a             -- ^ Fill a hole+  extract :: f a -> f (Loc f a)         -- ^ All extractions++-- The Functor constraint simplifies several signatures below.+instance Holey (Const z) where+  type Der (Const z) = Void+  fill = error "fill for Const z: no Der values"+  extract (Const z) = Const z++instance Holey Id where+  type Der Id = Unit+  fill (Const (), a) = Id a+  extract (Id a) = Id (Const (), a)++instance (Holey f, Holey g) => Holey (f :+: g) where+  type Der (f :+: g) = Der f :+: Der g+  fill (InL df, a) = InL (fill (df, a))+  fill (InR df, a) = InR (fill (df, a))+  extract (InL fa) = InL ((fmap.first) InL (extract fa))+  extract (InR ga) = InR ((fmap.first) InR (extract ga))++{-++InL fa :: (f :+: g) a++fa :: f a++extract fa :: f (Loc f a)++(fmap.first) InL (extract fa) :: f ((Der f :+: Der g) a, a)++(fmap.first) InL (extract fa) :: f ((Der (f :+: g) a), a)++InL ((fmap.first) InL (extract fa)) :: (f :+: g) ((Der (f :+: g) a), a)++-}+++-- Der (f :*: g) = Der f :*: g  :+:  f :*: Der g++instance (Holey f, Holey g) => Holey (f :*: g) where+  type Der (f :*: g) = Der f :*: g  :+:  f :*: Der g+  fill (InL (dfa :*:  ga), a) = fill (dfa, a) :*: ga+  fill (InR ( fa :*: dga), a) = fa :*: fill (dga, a)+  extract (fa :*: ga) = (fmap.first) (InL . (:*: ga)) (extract fa) :*:+                        (fmap.first) (InR . (fa :*:)) (extract ga)++{-++fa :*: ga :: (f :*: g) a++fa :: f a++extract fa :: f (Loc f a)++(fmap.first) (:*: ga) (extract fa) :: f ((Der f :*: g) a, a)++(fmap.first) (InL . (:*: ga)) (extract fa)+  :: f (((Der f :*: g) :+: (f :*: Der g)) a, a)++(fmap.first) (InL . (:*: ga)) (extract fa) :: f ((Der (f :*: g)) a, a)++(fmap.first) (InR . (fa :*:)) (extract ga) :: g ((Der (f :*: g)) a, a)+++(fmap.first) (InL . (:*: ga)) (extract fa) :*: (fmap.first) (InR . (fa :*:)) (extract ga)+  :: (f :*: g) (Der (f :*: g) a, a)++-}++-- type instance Der (g :.  f) = Der g :. f  :*:  Der f+++lassoc :: (p,(q,r)) -> ((p,q),r)+lassoc    (p,(q,r)) =  ((p,q),r)++squishP :: Functor f => (a, f b) -> f (a,b)+squishP (a,fb) = fmap (a,) fb++tweak1 :: Functor f => (dg (fa), f (dfa, a)) -> f ((dg (fa), dfa), a)+tweak1 = fmap lassoc . squishP++chainRule :: (dg (f a), df a) -> ((dg :. f) :*: df) a+chainRule (dgfa, dfa) = O dgfa :*: dfa++tweak2 :: Functor f => (dg (f a), f (df a, a)) -> f (((dg :. f) :*: df) a, a)+tweak2 = (fmap.first) chainRule . tweak1++-- And more specifically,+-- +-- tweak2 :: Functor f => (Der g (f a), f (Loc f a)) -> f (((Der g :. f) :*: Der f) a, a)+-- tweak2 :: Functor f => (Der g (f a), f (Loc f a)) -> f (Der (g :. f) a, a)++{-+(dg fa, f (dfa,a))++f (dg fa, (df,a))++f ((dg fa, dfa), a)+-}++extractGF :: (Holey f, Holey g) =>+             g (f a) -> g (f (Loc (g :. f) a))+extractGF = fmap (tweak2 . second extract) . extract++{-++gfa :: g (f a)++extract gfa :: g (Der g (f a), f a)++fmap (second extract) (extract gfa) :: g (Der g (f a), f (Loc f a))++fmap (tweak2 . second extract) (extract gfa) +  :: g (f ((Der (g :. f :*: Der f) a), a))++-}++-- Der (g :.  f) = Der g :. f  :*:  Der f++instance (Holey f, Holey g) => Holey (g :. f) where+  type Der (g :.  f) = Der g :. f  :*:  Der f+  -- fill (O dgfa :*: dfa) = O . fill dgfa . fill dfa+  fill (O dgfa :*: dfa, a) = O (fill (dgfa, fill (dfa, a)))+  -- extract (O gfa) = O (extractGF gfa)+  extract = inO extractGF+++{-+O dgfa :*: dfa :: Der (g :. f) a++O dgfa :*: dfa :: (Der g :. f :*: Der f) a++dgfa :: Der g (f a)+dfa  :: Der f a++fill dfa a :: f a++fill dgfa (fill dfa a) :: g (f a)++O (fill dgfa (fill dfa a)) :: (g :. f) a++-}
+ src/FunctorCombo/Derivative.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TypeFamilies, TypeOperators #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.Derivative+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Derivatives (one-hole contexts) for standard Functor combinators+----------------------------------------------------------------------++module FunctorCombo.Derivative (Der) where++import FunctorCombo.Functor++{--------------------------------------------------------------------+    Derivatives, i.e., one-hole contexts+--------------------------------------------------------------------}++-- | A derivative, i.e., a one-hole context for a container f (probably a functor).+type family Der (f :: (* -> *)) :: (* -> *)++type instance Der (Const a) = Void++type instance Der Id = Unit++type instance Der (f :+: g) = Der f :+: Der g++type instance Der (f :*: g) = Der f :*: g  :+:  f :*: Der g++type instance Der (g :.  f) = Der g :. f  :*:  Der f+
+ src/FunctorCombo/FixC.hs view
@@ -0,0 +1,97 @@+-- {-# LANGUAGE #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.FixC+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Zippers for functor fixpoints+----------------------------------------------------------------------++module FunctorCombo.FixC (FixC,LocFix, up,down) where++-- import FunctorCombo.Derivative+-- import FunctorCombo.Holey++import FunctorCombo.DHoley++++newtype Fix f = Fix { unFix :: f (Fix f) }++-- If Haskell had recursive type synonyms:+-- +--   Fix f =~ f (Fix f)+++-- | Context for functor fixpoints++-- data FixC f = FixC (Der f (Fix f)) (FixC f)++-- type FixC f = Stream (Der f (Fix f))++-- Or, if we want topped data types:++-- data FixC f = TopC | FixC (Der f (Fix f)) (FixC f)++-- Isomorphically:++type FixC f = [Der f (Fix f)]++-- Reminder:+-- +--   type Loc f a = (Der f a, a)++-- Instead,++type LocFix f = (FixC f, Fix f)++-- TODO: can I relate FixC to Der (Fix f) and use Loc for LocFix?++up :: Holey f => LocFix f -> LocFix f+up ([],_) = error "up: already at top"+up (d:ds', t) = (ds', Fix (fill (d,t)))++{-++(d:ds', t) :: LocFix f+(d:ds', t) :: (FixC f, Fix f)++d:ds' :: [Der f (Fix f)]++t :: Fix f++d   ::  Der f (Fix f)+ds' :: [Der f (Fix f)]++fill :: Loc f b -> f b++fill (d,t) :: f (Fix f)++Fix (fill (d,t)) :: Fix f++-}++down :: Holey f => LocFix f -> f (LocFix f)+down (ds', t) = fmap (\ (d,t') -> (d:ds',t')) (extract (unFix t))++{-+(ds',t) :: LocFix f+(ds',t) :: (FixC f, Fix f)+(ds',t) :: ([Der f (Fix f)], Fix f)++ds' :: [Der f (Fix f)]+t :: Fix f+unFix t :: f (Fix f)++extract (unFix t) :: f (Der f (Fix f), Fix f)++fmap (\ (d,t') -> (d:ds',t')) (extract (unFix t))+  :: ([Der f (Fix f)], Fix f)+  :: (FixC f, Fix f)+  :: LocFix f+-}
+ src/FunctorCombo/Functor.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TypeOperators, EmptyDataDecls, StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.Functor+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Standard building blocks for functors+----------------------------------------------------------------------++module FunctorCombo.Functor+  (+    Const(..),Void,Unit,Id(..),unId,inId,inId2,(:+:)(..),eitherF+  , (:*:)(..),(:.)(..),unO,inO,inO2,(~>)+  ) where+++import Control.Applicative (Applicative(..),Const(..))++import Control.Compose (Id(..),unId,inId,inId2,(:.)(..),unO,inO,inO2,(~>))+++-- infixl 9 :.+infixl 7 :*:+infixl 6 :+:+++{--------------------------------------------------------------------+    Generic functor constructors+--------------------------------------------------------------------}++-- | Empty/zero type constructor (no inhabitants)+data Void a++-- | Unit type constructor (one inhabitant)+type Unit = Const ()++-- From Control.Compose:+-- +--   data Id a = Id a++-- | Product on unary type constructors+data (f :*: g) a = f a :*: g a deriving (Show)++-- | Sum on unary type constructors+data (f :+: g) a = InL (f a) | InR (g a) deriving (Show)++eitherF :: (f a -> b) -> (g a -> b) -> (f :+: g) a -> b+eitherF p _ (InL fa) = p fa+eitherF _ q (InR ga) = q ga++-- From Control.Compose:+-- +--   newtype (g :. f) a = O (g (f a))+++{--------------------------------------------------------------------+    Functor and Applicative instances for generic constructors+--------------------------------------------------------------------}++instance Functor Void where+  fmap _ = error "Void fmap: no void value"  -- so ghc won't complain++-- instance Functor Id where+--   fmap h (Id a) = Id (h a)++-- deriving instance Functor Id++-- instance (Functor f, Functor g) => Functor (f :+: g) where+--   fmap h (InL fa) = InL (fmap h fa)+--   fmap h (InR ga) = InR (fmap h ga)++-- i.e.,+-- +--     fmap h . InL  ==  InL . fmap h+--     fmap h . InR  ==  InR . fmap h++deriving instance (Functor f, Functor g) => Functor (f :+: g)++-- instance (Functor f, Functor g) => Functor (f :*: g) where+--   fmap h (fa :*: ga) = fmap h fa :*: fmap h ga++-- Or:+deriving instance (Functor f, Functor g) => Functor (f :*: g)++-- TODO: Verify that the deriving instances are equivalent to the explicit versions.++-- What about Applicative instances?  I think Void could implement (<*>)+-- but not pure.  Hm.  Id and (:*:) are easy, while (:+:) is problematic.++-- instance Applicative Id where+--   pure a = Id a+--   Id f <*> Id x = Id (f x)++-- instance Applicative Id where+--   pure  = Id+--   (<*>) = inId2 ($)++instance (Applicative f, Applicative g) => Applicative (f :*: g) where+  pure a = pure a :*: pure a+  (f :*: g) <*> (a :*: b) = (f <*> a) :*: (g <*> b)++-- instance (Functor g, Functor f) => Functor (g :. f) where+--   fmap = inO.fmap.fmap++-- or++-- deriving instance (Functor g, Functor f) => Functor (g :. f)
+ src/FunctorCombo/Holey.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TypeFamilies, TypeOperators, TupleSections #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.Holey+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Filling and extracting derivatives (one-hole contexts)+----------------------------------------------------------------------++module FunctorCombo.Holey (Loc,Holey(..)) where++import Control.Arrow (first,second)++import FunctorCombo.Functor+import FunctorCombo.Derivative+++{--------------------------------------------------------------------+    Extraction+--------------------------------------------------------------------}++-- | Location, i.e., one-hole context and a value for the hole.+type Loc f a = (Der f a, a)++-- | Filling and creating one-hole contexts+class Functor f => Holey f where+  fill    :: Loc f a -> f a             -- ^ Fill a hole+  extract :: f a -> f (Loc f a)         -- ^ All extractions++-- The Functor constraint simplifies several signatures below.++instance Holey (Const z) where+  fill = error "fill for Const z: no Der values"+  extract (Const z) = Const z++instance Holey Id where+  fill (Const (), a) = Id a+  extract (Id a) = Id (Const (), a)++instance (Holey f, Holey g) => Holey (f :+: g) where+  fill (InL df, a) = InL (fill (df, a))+  fill (InR df, a) = InR (fill (df, a))+  extract (InL fa) = InL ((fmap.first) InL (extract fa))+  extract (InR ga) = InR ((fmap.first) InR (extract ga))++{-++InL fa :: (f :+: g) a++fa :: f a++extract fa :: f (Loc f a)++(fmap.first) InL (extract fa) :: f ((Der f :+: Der g) a, a)++(fmap.first) InL (extract fa) :: f ((Der (f :+: g) a), a)++InL ((fmap.first) InL (extract fa)) :: (f :+: g) ((Der (f :+: g) a), a)++-}+++-- Der (f :*: g) = Der f :*: g  :+:  f :*: Der g++instance (Holey f, Holey g) => Holey (f :*: g) where+  fill (InL (dfa :*:  ga), a) = fill (dfa, a) :*: ga+  fill (InR ( fa :*: dga), a) = fa :*: fill (dga, a)+  extract (fa :*: ga) = (fmap.first) (InL . (:*: ga)) (extract fa) :*:+                        (fmap.first) (InR . (fa :*:)) (extract ga)++{-++fa :*: ga :: (f :*: g) a++fa :: f a++extract fa :: f (Loc f a)++(fmap.first) (:*: ga) (extract fa) :: f ((Der f :*: g) a, a)++(fmap.first) (InL . (:*: ga)) (extract fa)+  :: f (((Der f :*: g) :+: (f :*: Der g)) a, a)++(fmap.first) (InL . (:*: ga)) (extract fa) :: f ((Der (f :*: g)) a, a)++(fmap.first) (InR . (fa :*:)) (extract ga) :: g ((Der (f :*: g)) a, a)+++(fmap.first) (InL . (:*: ga)) (extract fa) :*: (fmap.first) (InR . (fa :*:)) (extract ga)+  :: (f :*: g) (Der (f :*: g) a, a)++-}++-- type instance Der (g :.  f) = Der g :. f  :*:  Der f+++lassoc :: (p,(q,r)) -> ((p,q),r)+lassoc    (p,(q,r)) =  ((p,q),r)++squishP :: Functor f => (a, f b) -> f (a,b)+squishP (a,fb) = fmap (a,) fb++tweak1 :: Functor f => (dg (fa), f (dfa, a)) -> f ((dg (fa), dfa), a)+tweak1 = fmap lassoc . squishP++chainRule :: (dg (f a), df a) -> ((dg :. f) :*: df) a+chainRule (dgfa, dfa) = O dgfa :*: dfa++tweak2 :: Functor f => (dg (f a), f (df a, a)) -> f (((dg :. f) :*: df) a, a)+tweak2 = (fmap.first) chainRule . tweak1++-- And more specifically,+-- +-- tweak2 :: Functor f => (Der g (f a), f (Loc f a)) -> f (((Der g :. f) :*: Der f) a, a)+-- tweak2 :: Functor f => (Der g (f a), f (Loc f a)) -> f (Der (g :. f) a, a)++{-+(dg fa, f (dfa,a))++f (dg fa, (df,a))++f ((dg fa, dfa), a)+-}++extractGF :: (Holey f, Holey g) =>+             g (f a) -> g (f (Loc (g :. f) a))+extractGF = fmap (tweak2 . second extract) . extract++{-++gfa :: g (f a)++extract gfa :: g (Der g (f a), f a)++fmap (second extract) (extract gfa) :: g (Der g (f a), f (Loc f a))++fmap (tweak2 . second extract) (extract gfa) +  :: g (f ((Der (g :. f :*: Der f) a), a))++-}++-- Der (g :.  f) = Der g :. f  :*:  Der f++instance (Holey f, Holey g) => Holey (g :. f) where+  -- fill (O dgfa :*: dfa) = O . fill dgfa . fill dfa+  fill (O dgfa :*: dfa, a) = O (fill (dgfa, fill (dfa, a)))+  -- extract (O gfa) = O (extractGF gfa)+  extract = inO extractGF+++{-+O dgfa :*: dfa :: Der (g :. f) a++O dgfa :*: dfa :: (Der g :. f :*: Der f) a++dgfa :: Der g (f a)+dfa  :: Der f a++fill dfa a :: f a++fill dgfa (fill dfa a) :: g (f a)++O (fill dgfa (fill dfa a)) :: (g :. f) a++-}
+ src/FunctorCombo/LocT.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.LocT+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- +----------------------------------------------------------------------++module FunctorCombo.LocT+  (+    Context,LocT, up, down+  ) where+++-- import FunctorCombo.Derivative+-- import FunctorCombo.Holey++import FunctorCombo.DHoley++import FunctorCombo.Regular++-- TODO: Bring in pattern functors (as in PolyP), so I don't have to+-- work on fixpoints directly.  Something like+-- +--   type Context t = [Der (PF t) t]+-- +--   type LocT t = (Context t, t)+-- +-- Then use with some standard recursive data types like lists & trees.++-- TODO: Consider the implications of my style of zipper, using f (Der+-- ...), contrasted with the traditional one.  Try an application of mine+-- to make sure it's useful.  And that I avoid staring into the void.++-- TODO: rename wrap/unwrap, e.g., to reg/unreg++type Context t = [Der (PF t) t]++type LocT t = (Context t, t)++up :: (Regular t, Holey (PF t)) => LocT t -> LocT t+up ([],_) = error "up: already at top"+up (d:ds', t) = (ds', wrap (fill (d,t)))+++down :: (Regular t, Holey (PF t)) => LocT t -> PF t (LocT t)+down (ds', t) = fmap (\ (d,t') -> (d:ds',t')) (extract (unwrap t))++{-++type P = Id :*: Id                      -- pairs+type Q = P  :*: P                       -- quadruples (or P :. P)++type Two  a = (a,a)++type Four a = Two (Two a)++data QuadTree a = QuadTree a (Four (QuadTree a))++instance Regular (QuadTree a) where+  type PF (QuadTree a) = Const a :*: Q+  unwrap (QuadTree a ((p,q),(r,s))) =+    Const a :*: ((Id p :*: Id q) :*: (Id r :*: Id s))+  wrap (Const a :*: ((Id p :*: Id q) :*: (Id r :*: Id s))) =+    QuadTree a ((p,q),(r,s))++-}
+ src/FunctorCombo/MemoTrie.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances, CPP+ #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}  -- temporary while testing+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.MemoTrie+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Functor-based memo tries (strict for now)+-- +-- Warning: this formulation cannot handle recursive types.+-- The type checker fails to terminate.  Wondering about solutions.+----------------------------------------------------------------------++module FunctorCombo.MemoTrie+  (+    HasTrie(..),memo,memo2,memo3+  ) where++import Control.Arrow (first)+import Control.Applicative ((<$>))++import qualified Data.IntTrie as IT  -- data-inttrie+import Data.Tree++import Control.Compose (result)++import FunctorCombo.Functor+import FunctorCombo.Regular+++{--------------------------------------------------------------------+    Class+--------------------------------------------------------------------}++infixr 0 :->:++-- | Memo trie from k to v+type k :->: v = Trie k v++-- | Domain types with associated memo tries+class HasTrie k where+    -- | Representation of trie with domain type @a@+    type Trie k :: * -> *+    -- | Create the trie for the entire domain of a function+    trie   :: (k  ->  v) -> (k :->: v)+    -- | Convert k trie to k function, i.e., access k field of the trie+    untrie :: (k :->: v) -> (k  ->  v)+    -- | List the trie elements.  Order of keys (@:: k@) is always the same.+    enumerate :: (k :->: v) -> [(k,v)]++-- -- | Domain elements of a trie+-- domain :: HasTrie a => [a]+-- domain = map fst (enumerate (trie (const oops)))+--  where+--    oops = error "Data.MemoTrie.domain: range element evaluated."+++{--------------------------------------------------------------------+    Memo functions+--------------------------------------------------------------------}++-- | Trie-based function memoizer+memo :: HasTrie k => Unop (k -> v)+memo = untrie . trie++-- | Memoize a binary function, on its first argument and then on its+-- second.  Take care to exploit any partial evaluation.+memo2 :: (HasTrie s,HasTrie t) => Unop (s -> t -> a)++-- | Memoize a ternary function on successive arguments.  Take care to+-- exploit any partial evaluation.+memo3 :: (HasTrie r,HasTrie s,HasTrie t) => Unop (r -> s -> t -> a)++-- | Lift a memoizer to work with one more argument.+mup :: HasTrie t => (b -> c) -> (t -> b) -> (t -> c)+mup mem f = memo (mem . f)++memo2 = mup memo+memo3 = mup memo2++{--------------------------------------------------------------------+    Instances+--------------------------------------------------------------------}++instance HasTrie () where+  type Trie ()  = Id+  trie   f      = Id (f ())+  untrie (Id v) = const v+  enumerate (Id a) = [((),a)]++instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where+  type Trie (Either a b) = Trie a :*: Trie b+  trie   f           = trie (f . Left) :*: trie (f . Right)+  untrie (ta :*: tb) = untrie ta `either` untrie tb+  enumerate (ta :*: tb) = enum' Left ta `weave` enum' Right tb++enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)]+enum' f = (fmap.first) f . enumerate++weave :: [a] -> [a] -> [a]+[] `weave` as = as+as `weave` [] = as+(a:as) `weave` bs = a : (bs `weave` as)+++instance (HasTrie a, HasTrie b) => HasTrie (a , b) where+  type Trie (a , b) = Trie a :. Trie b+  trie   f = O (trie (trie . curry f))+  untrie (O tt) = uncurry (untrie . untrie tt)+  enumerate (O tt) =+    [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ]++-- Experiment:++#define HasTrieIsomorph(Context,Type,IsoType,toIso,fromIso) \+instance Context => HasTrie (Type) where {\+  type Trie (Type) = Trie (IsoType); \+  trie f = trie (f . (fromIso)); \+  untrie t = untrie t . (toIso); \+  enumerate = (result.fmap.first) (fromIso) enumerate; \+}+++HasTrieIsomorph( (), Bool, Either () ()+               , bool (Left ()) (Right ())+               , either (\ () -> True) (\ () -> False))++HasTrieIsomorph((HasTrie a, HasTrie b, HasTrie c), (a,b,c), ((a,b),c)+               , \ (a,b,c) -> ((a,b),c), \ ((a,b),c) -> (a,b,c))++HasTrieIsomorph((HasTrie a, HasTrie b, HasTrie c, HasTrie d)+               , (a,b,c,d), ((a,b,c),d)+               , \ (a,b,c,d) -> ((a,b,c),d), \ ((a,b,c),d) -> (a,b,c,d))+++-- As well as the functor combinators themselves++HasTrieIsomorph( HasTrie x, Const x a, x, getConst, Const )++HasTrieIsomorph( HasTrie a, Id a, a, unId, Id )++HasTrieIsomorph( (HasTrie (f a), HasTrie (g a))+               , (f :*: g) a, (f a,g a)+               , \ (fa :*: ga) -> (fa,ga), \ (fa,ga) -> (fa :*: ga) )++HasTrieIsomorph( (HasTrie (f a), HasTrie (g a))+               , (f :+: g) a, Either (f a) (g a)+               , eitherF Left Right, either InL InR )++HasTrieIsomorph( HasTrie (g (f a))+               , (g :. f) a, g (f a) , unO, O )+++++-- #define HasTrieRegular(Context,Type) \+-- HasTrieIsomorph(Context, Type, PF (Type) (Type) , unwrap, wrap)++-- #define HasTrieRegular1(TypeCon) \+-- HasTrieRegular(HasTrie a, TypeCon a)++-- Hangs ghc 6.12.1:+-- +-- HasTrieRegular(HasTrie a, [a])+-- HasTrieRegular(HasTrie a, Tree a)++-- HasTrieRegular1([])+-- HasTrieRegular1(Tree)++-- I think the problem is infinite types.  Try an explicit newtype to+-- break the cycle.+++-- newtype ListTrie a v = ListTrie (PF [a] [a] :->: v)+ +-- instance HasTrie a => HasTrie [a] where+--   type Trie [a] = ListTrie a+--   trie f = ListTrie (trie (f . wrap))+--   untrie (ListTrie t) = untrie t . unwrap+--   enumerate (ListTrie t) = (result.fmap.first) wrap enumerate $ t++-- Works.  Now abstract into a macro++#define HasTrieRegular(Context,Type,TrieType,TrieCon) \+newtype TrieType v = TrieCon (PF (Type) (Type) :->: v); \+instance Context => HasTrie (Type) where { \+  type Trie (Type) = TrieType; \+  trie f = TrieCon (trie (f . wrap)); \+  untrie (TrieCon t) = untrie t . unwrap; \+  enumerate (TrieCon t) = (result.fmap.first) wrap enumerate t; \+}; \+HasTrieIsomorph( HasTrie (PF (Type) (Type) :->: v) \+               , TrieType v, PF (Type) (Type) :->: v \+               , \ (TrieCon w) -> w, TrieCon )++-- For instance,++-- HasTrieRegular(HasTrie a, [a] , ListTrie a, ListTrie)+-- HasTrieRegular(HasTrie a, Tree, TreeTrie a, TreeTrie)++-- Simplify a bit with a macro for unary regular types.+-- Make similar defs for binary etc as needed.++#define HasTrieRegular1(TypeCon,TrieCon) \+HasTrieRegular(HasTrie a, TypeCon a, TrieCon a, TrieCon)++HasTrieRegular1([]  , ListTrie)+HasTrieRegular1(Tree, TreeTrie)++-- HasTrieIsomorph(Context,Type,IsoType,toIso,fromIso)++-- HasTrieIsomorph( HasTrie (PF [a] [a] :->: v)+--                , ListTrie a v, PF [a] [a] :->: v+--                , \ (ListTrie w) -> w, ListTrie )++++++enumerateEnum :: (Enum k, Num k, HasTrie k) => (k :->: v) -> [(k,v)]+enumerateEnum t = [(k, f k) | k <- [0 ..] `weave` [-1, -2 ..]]+ where+   f = untrie t++#define HasTrieIntegral(Type) \+instance HasTrie Type where { \+  type Trie Type = IT.IntTrie; \+  trie   = (<$> IT.identity); \+  untrie = IT.apply; \+  enumerate = enumerateEnum; \+}++HasTrieIntegral(Int)+HasTrieIntegral(Integer)+++-- Memoizing higher-order functions++HasTrieIsomorph((HasTrie a, HasTrie (a :->: b)), a -> b, a :->: b, trie, untrie)+++{--------------------------------------------------------------------+    Misc+--------------------------------------------------------------------}++type Unop a = a -> a++bool :: a -> a -> Bool -> a+bool t e b = if b then t else e++{-++{--------------------------------------------------------------------+    Testing+--------------------------------------------------------------------}++fib :: Integer -> Integer+fib m = mfib m+ where+   mfib = memo fib'+   fib' 0 = 0+   fib' 1 = 1+   fib' n = mfib (n-1) + mfib (n-2)++-- The eta-redex in fib is important to prevent a CAF.+++-}++{-++ft1 :: (Bool -> a) -> (a,a)+ft1 f = (f False, f True)++f1 :: Bool -> Int+f1 False = 0+f1 True  = 1++trie1a :: (Bool -> Int) :->: (Int, Int)+trie1a = trie ft1++trie1b :: (Bool :->: Int) :->: (Int, Int)+trie1b = trie1a++trie1c :: (Either () () :->: Int) :->: (Int, Int)+trie1c = trie1a++trie1d :: ((Trie () :*: Trie ()) Int) :->: (Int, Int)+trie1d = trie1a++trie1e :: (Trie () Int, Trie () Int) :->: (Int, Int)+trie1e = trie1a++trie1f :: (() :->: Int, () :->: Int) :->: (Int, Int)+trie1f = trie1a++trie1g :: (Int, Int) :->: (Int, Int)+trie1g = trie1a++trie1h :: (Trie Int :. Trie Int) (Int, Int)+trie1h = trie1a++trie1i :: Int :->: Int :->: (Int, Int)+trie1i = unO trie1a++-}
+ src/FunctorCombo/Regular.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.Regular+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Regular data types+----------------------------------------------------------------------++module FunctorCombo.Regular (Regular(..)) where++import Data.Tree++import FunctorCombo.Functor+++-- Pattern functors, similar to PolyC and the Regular class from+-- UU (e.g., "A Lightweight Approach to Datatype-Generic Rewriting")++class Functor (PF t) => Regular t where+  type PF t :: * -> *+  wrap   :: PF t t -> t+  unwrap :: t -> PF t t+++-- Some Regular instances:++instance Regular [a] where+  type PF [a] = Unit :+: Const a :*: Id+  unwrap []     = InL (Const ())+  unwrap (a:as) = InR (Const a :*: Id as)+  wrap (InL (Const ()))          = []+  wrap (InR (Const a :*: Id as)) = a:as+++-- Rose tree (from Data.Tree)+-- +--   data Tree  a = Node a [Tree a]++-- instance Functor Tree where+--   fmap f (Node a ts) = Node (f a) (fmap f ts)++instance Regular (Tree a) where+  type PF (Tree a) = Const a :*: []+  unwrap (Node a ts) = Const a :*: ts+  wrap (Const a :*: ts) = Node a ts