packages feed

functor-combo 0.0.2 → 0.0.3

raw patch · 9 files changed

+889/−129 lines, 9 filesdep +lub

Dependencies added: lub

Files

functor-combo.cabal view
@@ -1,5 +1,5 @@ Name:                functor-combo-Version:             0.0.2+Version:             0.0.3 Cabal-Version:       >= 1.2 Synopsis:            Functor combinators with tries & zippers Category:            Data@@ -27,16 +27,21 @@ Library   hs-Source-Dirs:      src   Extensions:-  Build-Depends:       base<5, TypeCompose >= 0.8, containers, data-inttrie+  Build-Depends:       base<5, TypeCompose >= 0.8, containers, data-inttrie, lub   Exposed-Modules:                             FunctorCombo.Functor+                       FunctorCombo.Lub                        FunctorCombo.Derivative                        FunctorCombo.Holey                        FunctorCombo.DHoley                        FunctorCombo.FixC                        FunctorCombo.Regular                        FunctorCombo.LocT-                       FunctorCombo.MemoTrie+                       FunctorCombo.StrictMemo+                       FunctorCombo.NonstrictMemo   ghc-options:         -Wall++--                       FunctorCombo.MemoTrie+  --  ghc-prof-options:    -prof -auto-all
src/FunctorCombo/DHoley.hs view
@@ -14,7 +14,7 @@ -- Variation on Holey, integrating 'Der' ---------------------------------------------------------------------- -module FunctorCombo.DHoley (Holey(..)) where+module FunctorCombo.DHoley (Holey(..), fill) where  import Control.Arrow (first,second) @@ -28,29 +28,33 @@ -- | Location, i.e., one-hole context and a value for the hole. type Loc f a = (Der f a, a) +-- | Alternative interface for 'fillC'.+fill :: Holey f => Loc f a -> f a+fill = uncurry fillC+ class Functor f => Holey f where   -- | Derivative, i.e., one-hole context   type Der f :: * -> *   -- | Fill a hole-  fill    :: Loc f a -> f a+  fillC   :: Der f a -> a -> f a   -- | All extractions   extract :: f a -> f (Loc f a)  -- 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 (Const x) where+  type Der (Const x) = Void+  fillC = voidF+  extract (Const x) = Const x  instance Holey Id where   type Der Id = Unit-  fill (Const (), a) = Id a+  fillC (Const ()) = Id   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))+  fillC (InL df) = InL . fillC df+  fillC (InR df) = InR . fillC df   extract (InL fa) = InL ((fmap.first) InL (extract fa))   extract (InR ga) = InR ((fmap.first) InR (extract ga)) @@ -62,6 +66,8 @@  extract fa :: f (Loc f a) +extract fa :: f (Der f a, a)+ (fmap.first) InL (extract fa) :: f ((Der f :+: Der g) a, a)  (fmap.first) InL (extract fa) :: f ((Der (f :+: g) a), a)@@ -75,8 +81,8 @@  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)+  fillC (InL (dfa :*:  ga)) = (:*: ga) . fillC dfa+  fillC (InR ( fa :*: dga)) = (fa :*:) . fillC dga   extract (fa :*: ga) = (fmap.first) (InL . (:*: ga)) (extract fa) :*:                         (fmap.first) (InR . (fa :*:)) (extract ga) @@ -155,9 +161,7 @@  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)+  fillC (O dgfa :*: dfa) = O. fillC dgfa . fillC dfa   extract = inO extractGF  @@ -169,10 +173,10 @@ dgfa :: Der g (f a) dfa  :: Der f a -fill dfa a :: f a+fillC dfa a :: f a -fill dgfa (fill dfa a) :: g (f a)+fillC dgfa (fillC dfa a) :: g (f a) -O (fill dgfa (fill dfa a)) :: (g :. f) a+O (fillC dgfa (fillC dfa a)) :: (g :. f) a  -}
src/FunctorCombo/FixC.hs view
@@ -14,6 +14,8 @@  module FunctorCombo.FixC (FixC,LocFix, up,down) where +import Control.Arrow (first)+ -- import FunctorCombo.Derivative -- import FunctorCombo.Holey @@ -52,9 +54,9 @@  -- 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)))+up :: Holey f => LocFix f -> Maybe (LocFix f)+up ([]   , _) = Nothing+up (d:ds', t) = Just (ds', Fix (fill (d,t)))  {- @@ -77,7 +79,11 @@ -}  down :: Holey f => LocFix f -> f (LocFix f)-down (ds', t) = fmap (\ (d,t') -> (d:ds',t')) (extract (unFix t))+down (ds', t) = fmap (first (:ds')) (extract (unFix t))++-- down (ds', t) = fmap (\ (d,t') -> (d:ds',t')) (extract (unFix t))++  {- (ds',t) :: LocFix f
src/FunctorCombo/Functor.hs view
@@ -14,8 +14,9 @@  module FunctorCombo.Functor   (-    Const(..),Void,Unit,Id(..),unId,inId,inId2,(:+:)(..),eitherF+    Const(..),Void,voidF,Unit,unit,Id(..),unId,inId,inId2,(:+:)(..),eitherF   , (:*:)(..),(:.)(..),unO,inO,inO2,(~>)+  , pairF, unPairF, inProd, inProd2   ) where  @@ -36,9 +37,17 @@ -- | Empty/zero type constructor (no inhabitants) data Void a +voidF :: Void a -> b+voidF = error "voidF: no value of type Void"++ -- | Unit type constructor (one inhabitant) type Unit = Const () +-- | The unit value+unit :: Unit ()+unit = Const ()+ -- From Control.Compose: --  --   newtype Id a = Id a@@ -65,6 +74,20 @@ instance Functor Void where   fmap _ = error "Void fmap: no void value"  -- so ghc won't complain +-- deriving instance Functor Void+-- +-- Leads to+-- +-- ghc: panic! (the 'impossible' happened)+--   (GHC version 6.12.1 for i386-apple-darwin):+-- 	TcPat.checkArgs+-- +-- See ticket <http://hackage.haskell.org/trac/ghc/ticket/4220>.+-- +-- TODO: replace explicit definition with deriving, when the compiler fix+-- has been around for a while.++ -- instance Functor Id where --   fmap h (Id a) = Id (h a) @@ -110,3 +133,26 @@ -- or  -- deriving instance (Functor g, Functor f) => Functor (g :. f)+++{--------------------------------------------------------------------+    Some handy structural manipulators+--------------------------------------------------------------------}++pairF :: (f a, g a) -> (f :*: g) a+pairF (fa , ga) = (fa :*: ga)++-- pairF = uncurry (:*:)++unPairF :: (f :*: g) a -> (f a, g a)+unPairF (fa :*: ga) = (fa , ga)++-- Could also define curryF, uncurryF++inProd :: ((f a , g a) -> (h b , i b)) -> ((f :*: g) a -> (h :*: i) b)+inProd = unPairF ~> pairF+++inProd2 :: ((f a , g a) -> (h b , i b) -> (j c , k c))+        -> ((f :*: g) a -> (h :*: i) b -> (j :*: k) c)+inProd2 = unPairF ~> inProd
src/FunctorCombo/Holey.hs view
@@ -12,7 +12,7 @@ -- Filling and extracting derivatives (one-hole contexts) ---------------------------------------------------------------------- -module FunctorCombo.Holey (Loc,Holey(..)) where+module FunctorCombo.Holey (Loc,Holey(..),fill) where  import Control.Arrow (first,second) @@ -27,27 +27,43 @@ -- | Location, i.e., one-hole context and a value for the hole. type Loc f a = (Der f a, a) +-- | Alternative interface for 'fillC'.+fill :: Holey f => Loc f a -> f a+fill = uncurry fillC+ -- | Filling and creating one-hole contexts class Functor f => Holey f where-  fill    :: Loc f a -> f a             -- ^ Fill a hole+  fillC    :: Der f a -> 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"+  fillC = voidF   extract (Const z) = Const z  instance Holey Id where-  fill (Const (), a) = Id a+  fillC (Const ()) = Id   extract (Id a) = Id (Const (), a) +-- fillC (Const ()) a = Id a++-- fill (Const (), a) = Id 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))+  fillC (InL df) = InL . fillC df+  fillC (InR df) = InR . fillC df   extract (InL fa) = InL ((fmap.first) InL (extract fa))   extract (InR ga) = InR ((fmap.first) InR (extract ga)) +-- fillC (InL df) a) = InL (fillC df a)+-- fillC (InR df) a) = InR (fillC df a)++-- fill (InL df, a) = InL (fill (df, a))+-- fill (InR df, a) = InR (fill (df, a))++--   fillC = eitherF ((result.result) InL fillC) ((result.result) InR fillC)+ {-  InL fa :: (f :+: g) a@@ -68,11 +84,18 @@ -- 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)+  fillC (InL (dfa :*:  ga)) = (:*: ga) . fillC dfa+  fillC (InR ( fa :*: dga)) = (fa :*:) . fillC dga   extract (fa :*: ga) = (fmap.first) (InL . (:*: ga)) (extract fa) :*:                         (fmap.first) (InR . (fa :*:)) (extract ga) +-- fillC (InL (dfa :*:  ga)) a = fillC dfa a :*: ga+-- fillC (InR ( fa :*: dga)) a = fa :*: fillC dga a++-- fill (InL (dfa :*:  ga), a) = fill (dfa, a) :*: ga+-- fill (InR ( fa :*: dga), a) = fa :*: fill (dga, a)++ {-  fa :*: ga :: (f :*: g) a@@ -147,12 +170,14 @@ -- 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)))+  fillC (O dgfa :*: dfa) = O. fillC dgfa . fillC dfa+  -- fillC (O dgfa :*: dfa) a = O (fillC dgfa (fillC dfa a))   -- extract (O gfa) = O (extractGF gfa)   extract = inO extractGF +-- fill (O dgfa :*: dfa, a) = O (fill (dgfa, fill (dfa, a))) + {- O dgfa :*: dfa :: Der (g :. f) a @@ -161,10 +186,10 @@ dgfa :: Der g (f a) dfa  :: Der f a -fill dfa a :: f a+fillC dfa a :: f a -fill dgfa (fill dfa a) :: g (f a)+fillC dgfa (fillC dfa a) :: g (f a) -O (fill dgfa (fill dfa a)) :: (g :. f) a+O (fillC dgfa (fillC dfa a)) :: (g :. f) a  -}
src/FunctorCombo/LocT.hs view
@@ -18,6 +18,8 @@   ) where  +import Control.Arrow (first)+ -- import FunctorCombo.Derivative -- import FunctorCombo.Holey @@ -44,13 +46,13 @@  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)))+up :: (Regular t, Holey (PF t)) => LocT t -> Maybe (LocT t)+up ([],_) = Nothing+up (d:ds', t) = Just (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))+down (ds', t) = fmap (first (:ds')) (extract (unwrap t))  {-
+ src/FunctorCombo/Lub.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE StandaloneDeriving, TypeOperators, FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.Lub+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  GPL-3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Least upper bounds for functor combinators+----------------------------------------------------------------------++module FunctorCombo.Lub (HasLubF) where++import Data.Lub++import FunctorCombo.Functor++-- deriving instance HasLub a => HasLub (Id a)++-- Kills ghc: genDerivBinds: bad derived class lub-0.0.6:Data.Lub.HasLub{tc r3S}++-- ghc: panic! (the 'impossible' happened)+--   (GHC version 6.12.1 for i386-apple-darwin):+-- 	genDerivBinds: bad derived class lub-0.0.6:Data.Lub.HasLub{tc r3S}++{-++instance HasLub a => HasLub (Id a) where+  lub = inId2 lub++instance (HasLub a, HasLub (f a), HasLub (g a))+  => HasLub ((f :*: g) a) where+    lub = inProd2 lub++-}++{--------------------------------------------------------------------+    Functor-level lubs+--------------------------------------------------------------------}++class HasLubF f where+  lubF :: HasLub v => f v -> f v -> f v++-- instance HasLubF Id where lubF = lub++-- instance (HasLubF f, HasLubF g) => HasLubF (f :*: g) where lubF = lub++-- Could not deduce (HasLub (f v), HasLub (g v)) from the context (HasLub v)+++instance HasLubF Id where lubF = inId2 lub++-- instance (HasLubF f, HasLubF g) => HasLubF (f :*: g) where lubF = inProd2 lub++-- Same error.+++instance (HasLubF f, HasLubF g) => HasLubF (f :*: g) where+  (p :*: q) `lubF` (r :*: s) = (p `lubF` r) :*: (q `lubF` s)++-- TODO: Fix to match lub on pairs.  Sublety with strictness.
src/FunctorCombo/MemoTrie.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances, CPP  #-} {-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-unused-binds #-}  -- temporary while testing+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}  -- temporary while testing ---------------------------------------------------------------------- -- | -- Module      :  FunctorCombo.MemoTrie@@ -11,7 +11,7 @@ -- Maintainer  :  conal@conal.net -- Stability   :  experimental -- --- Functor-based memo tries (strict for now)+-- Functor-based memo tries --  ---------------------------------------------------------------------- @@ -20,38 +20,88 @@     HasTrie(..),memo,memo2,memo3   ) where +#define NonstrictMemo+ import Control.Arrow (first) import Control.Applicative ((<$>))  import qualified Data.IntTrie as IT  -- data-inttrie import Data.Tree -import Control.Compose (result)+import Control.Compose (result)  -- TypeCompose +#ifdef NonstrictMemo+import Data.Lub+#endif+ import FunctorCombo.Functor import FunctorCombo.Regular   {--------------------------------------------------------------------+    Misc+--------------------------------------------------------------------}++type Unop a = a -> a++bool :: a -> a -> Bool -> a+bool t e b = if b then t else e+++{--------------------------------------------------------------------     Class --------------------------------------------------------------------}  infixr 0 :->: --- | Memo trie from k to v+#ifdef NonstrictMemo+data Trie k v = Trie v (STrie k v)+ type k :->: v = Trie k v +-- Bottom+bottom :: a+bottom = error "MemoTrie: evaluated bottom.  Oops!"++-- | Create the trie for the entire domain of a function+trie   :: HasLub(v) => HasTrie k => (k  ->  v) -> (k :->: v)+trie f = Trie (f bottom) (sTrie f)++-- | Convert k trie to k function, i.e., access k field of the trie+untrie :: HasLub(v) => HasTrie k => (k :->: v) -> (k  ->  v)+untrie (Trie b t) = const b `lub` sUntrie t++#else+type Trie k = STrie k++type k :->: v = k :-> v++-- Bogus HasLub constraint+#define HasLub(v) ()++trie   :: HasTrie k => (k  ->  v) -> (k :->: v)+trie = sTrie++untrie :: HasTrie k => (k :->: v) -> (k  ->  v)+untrie = sUntrie++#endif++-- | Memo trie from k to v+type k :-> v = STrie k v+ -- | Domain types with associated memo tries class HasTrie k where     -- | Representation of trie with domain type @a@-    type Trie k :: * -> *+    type STrie k :: * -> *     -- | Create the trie for the entire domain of a function-    trie   :: (k  ->  v) -> (k :->: v)+    sTrie   :: HasLub(v) => (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)]+    sUntrie :: HasLub(v) => (k :-> v) -> (k  ->  v) +--     -- | List the trie elements.  Order of keys (@:: k@) is always the same.+--     enumerate :: HasLub(v) => (k :-> v) -> [(k,v)]+ -- -- | Domain elements of a trie -- domain :: HasTrie a => [a] -- domain = map fst (enumerate (trie (const oops)))@@ -59,24 +109,27 @@ --    oops = error "Data.MemoTrie.domain: range element evaluated."  +-- TODO: what about enumerate and strict/nonstrict?++ {--------------------------------------------------------------------     Memo functions --------------------------------------------------------------------}  -- | Trie-based function memoizer-memo :: HasTrie k => Unop (k -> v)+memo :: HasLub(v) => 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)+memo2 :: HasLub(a) => (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)+memo3 :: HasLub(a) => (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 :: HasLub(c) => HasTrie t => (b -> c) -> (t -> b) -> (t -> c) mup mem f = memo (mem . f)  memo2 = mup memo@@ -87,40 +140,55 @@ --------------------------------------------------------------------}  instance HasTrie () where-  type Trie ()  = Id-  trie   f      = Id (f ())-  untrie (Id v) = const v-  enumerate (Id a) = [((),a)]+  type STrie ()  = Id+  sTrie   f      = Id (f ())+  sUntrie (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+  type STrie (Either a b) = Trie a :*: Trie b+  sTrie   f           = trie (f . Left) :*: trie (f . Right)+  sUntrie (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+-- enum' :: HasLub(b) => 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)+-- weave :: [a] -> [a] -> [a]+-- [] `weave` as = as+-- as `weave` [] = as+-- (a:as) `weave` bs = a : (bs `weave` as) +-- To do: rethink enumerate and come back to it.  How might enumeration+-- work in the presence of nonstrict memo tries?  Maybe lub the+-- approximation into each of the values enumerated from the strict memo tries.+-- Would it help any??  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 ]+  type STrie (a , b) = Trie a :. Trie b+  sTrie   f = O (trie (trie . curry f))+  sUntrie (O tt) = uncurry (untrie . untrie tt)+--   enumerate (O tt) =+--     [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ] --- Experiment:+-- Oops:+-- +--     Could not deduce (HasLub (Trie b v)) from the context (HasLub v)+--       arising from a use of `trie'+-- +--     Could not deduce (HasLub (Trie b v)) from the context (HasLub v)+--       arising from a use of `untrie' +-- Eep.  How to fix this one?++{-++ #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); \+instance Context => HasTrie (Type) where { \+  type STrie (Type) = Trie (IsoType); \+  sTrie f = sTrie (f . (fromIso)); \+  sUntrie t = sUntrie t . (toIso); \   enumerate = (result.fmap.first) (fromIso) enumerate; \ } @@ -155,42 +223,25 @@                , (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)- +-- 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+--   type STrie [a] = ListTrie a+--   sTrie f = ListTrie (trie (f . wrap))+--   sUntrie (ListTrie t) = sUntrie t . unwrap --   enumerate (ListTrie t) = (result.fmap.first) wrap enumerate $ t+-- HasTrieIsomorph( HasTrie (PF ([a]) ([a]) :->: v)+--                , ListTrie a v, PF ([a]) ([a]) :->: v+--                , \ (ListTrie w) -> w, ListTrie ) + -- 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; \+  type STrie (Type) = TrieType; \+  sTrie f = TrieCon (sTrie (f . wrap)); \+  sUntrie (TrieCon t) = sUntrie t . unwrap; \   enumerate (TrieCon t) = (result.fmap.first) wrap enumerate t; \ }; \ HasTrieIsomorph( HasTrie (PF (Type) (Type) :->: v) \@@ -199,8 +250,8 @@  -- For instance, --- HasTrieRegular(HasTrie a, [a] , ListTrie a, ListTrie)--- HasTrieRegular(HasTrie a, Tree, TreeTrie a, TreeTrie)+-- HasTrieRegular(HasTrie a, [a]   , ListTrie a, ListTrie)+-- HasTrieRegular(HasTrie a, Tree a, TreeTrie a, TreeTrie)  -- Simplify a bit with a macro for unary regular types. -- Make similar defs for binary etc as needed.@@ -211,6 +262,7 @@ HasTrieRegular1([]  , ListTrie) HasTrieRegular1(Tree, TreeTrie) + -- HasTrieIsomorph(Context,Type,IsoType,toIso,fromIso)  -- HasTrieIsomorph( HasTrie (PF [a] [a] :->: v)@@ -218,9 +270,6 @@ --                , \ (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@@ -228,9 +277,9 @@  #define HasTrieIntegral(Type) \ instance HasTrie Type where { \-  type Trie Type = IT.IntTrie; \-  trie   = (<$> IT.identity); \-  untrie = IT.apply; \+  type STrie Type = IT.IntTrie; \+  sTrie   = (<$> IT.identity); \+  sUntrie = IT.apply; \   enumerate = enumerateEnum; \ } @@ -243,15 +292,6 @@ 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- {-  {--------------------------------------------------------------------@@ -271,8 +311,6 @@  -} -{-- ft1 :: (Bool -> a) -> [a] ft1 f = [f False, f True] @@ -307,10 +345,7 @@ trie1i :: HasTrie a => a :->: a :->: [a] trie1i = unO trie1a --} -{-- ft2 :: ([Bool] -> Int) -> Int ft2 f = f (alts 15) @@ -328,5 +363,45 @@ -- ... (hang forever) ...  -- Would nonstrict memoization work?  <http://conal.net/blog/posts/nonstrict-memoization/>++f3 :: Bool -> Integer+f3 = const 3++-- *FunctorCombo.MemoTrie> f3 undefined+-- 3+-- *FunctorCombo.MemoTrie> memo f3 undefined+-- *** Exception: Prelude.undefined++f4 :: () -> Integer+f4 = const 4++-- *FunctorCombo.MemoTrie> f4 undefined+-- 4+-- *FunctorCombo.MemoTrie> memo f4 undefined+-- 4++f5 :: ((),()) -> Integer+f5 = const 5++-- *FunctorCombo.MemoTrie> f5 undefined+-- 5+-- *FunctorCombo.MemoTrie> memo f5 undefined+-- 5++f6 :: Either () () -> Integer+f6 = const 6++-- *FunctorCombo.MemoTrie> f6 undefined+-- 6+-- *FunctorCombo.MemoTrie> memo f6 undefined+-- *** Exception: Prelude.undefined++-- Aha!++t6 :: Either () () :-> Integer+t6 = trie f6++-- *FunctorCombo.MemoTrie> t6+-- Id 6 :*: Id 6  -}
+ src/FunctorCombo/NonstrictMemo.hs view
@@ -0,0 +1,533 @@+{-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances, CPP+           , DeriveFunctor, StandaloneDeriving+           , FlexibleContexts+ #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}  -- temporary while testing+----------------------------------------------------------------------+-- |+-- Module      :  FunctorCombo.NonstrictMemo+-- Copyright   :  (c) Conal Elliott 2010+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Functor-based memo tries+-- +----------------------------------------------------------------------++module FunctorCombo.NonstrictMemo+  (+    HasTrie(..),memo,memo2,memo3+  ) where++#define NonstrictMemo++import Control.Arrow (first)+import Control.Applicative ((<$>))++import qualified Data.IntTrie as IT  -- data-inttrie+import Data.Tree++import Control.Compose (result)  -- TypeCompose++#ifdef NonstrictMemo+import Data.Lub+#endif++import FunctorCombo.Functor+import FunctorCombo.Regular+++{--------------------------------------------------------------------+    Misc+--------------------------------------------------------------------}++type Unop a = a -> a++bool :: a -> a -> Bool -> a+bool t e b = if b then t else e+++{--------------------------------------------------------------------+    Class+--------------------------------------------------------------------}++infixr 0 :->:++#define FunctorSuperClass++#ifdef FunctorSuperClass++#define HasTrieContext(Ty) Functor (STrie(Ty))+#define HF(Ty) HasTrie (Ty)++#else+#define HasTrieContext(Ty) ()+#define HF(Ty) HasTrie (Ty), Functor (STrie (Ty))++#endif+++#ifdef NonstrictMemo+data Trie k v = Trie v (STrie k v)++deriving instance Functor (STrie k) => Functor (Trie k)++-- instance Functor (STrie k) => Functor (Trie k) where+--   fmap f (Trie b t) = Trie (f b) (fmap f t)++type k :->: v = Trie k v++-- Bottom+bottom :: a+bottom = error "MemoTrie: evaluated bottom.  Oops!"++-- | Create the trie for the entire domain of a function+trie   :: (HasTrie k{-, HasLub v-}) => (k  ->  v) -> (k :->: v)+trie f = Trie (f bottom) (sTrie f)++-- | Convert k trie to k function, i.e., access k field of the trie+untrie :: (HasTrie k, HasLub v) => (k :->: v) -> (k  ->  v)+untrie (Trie b t) = const b `lub` sUntrie t++#else+type Trie k = STrie k++type k :->: v = k :-> v++-- Bogus HasLub constraint+#define HasLub(v) ()++trie   :: HasTrie k => (k  ->  v) -> (k :->: v)+trie = sTrie++untrie :: HasTrie k => (k :->: v) -> (k  ->  v)+untrie = sUntrie++#endif++-- | Strict memo trie from k to v+type k :-> v = STrie k v++-- | Domain types with associated memo tries+class HasTrieContext(k) => HasTrie k where+    -- | Representation of trie with domain type @a@+    type STrie k :: * -> *+    -- | Create the trie for the entire domain of a function+    sTrie   :: {- HasLub(v) => -} (k  -> v) -> (k :-> v)+    -- | Convert k trie to k function, i.e., access k field of the trie+    sUntrie :: HasLub(v) => (k :-> v) -> (k  -> v)++--     -- | List the trie elements.  Order of keys (@:: k@) is always the same.+--     enumerate :: HasLub(v) => (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."+++-- TODO: what about enumerate and strict/nonstrict?+++{--------------------------------------------------------------------+    Memo functions+--------------------------------------------------------------------}++-- | Trie-based function memoizer+memo :: HasLub(v) => 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 :: HasLub(a) => (HasTrie s,HasTrie t) => Unop (s -> t -> a)++-- | Memoize a ternary function on successive arguments.  Take care to+-- exploit any partial evaluation.+memo3 :: HasLub(a) => (HasTrie r,HasTrie s,HasTrie t) => Unop (r -> s -> t -> a)++-- | Lift a memoizer to work with one more argument.+mup :: HasLub(c) => 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 STrie ()  = Id+  sTrie   f      = Id (f ())+  sUntrie (Id v) = \ () -> v+--   enumerate (Id a) = [((),a)]++instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where+  type STrie (Either a b) = Trie a :*: Trie b+  sTrie   f           = trie (f . Left) :*: trie (f . Right)+  sUntrie (ta :*: tb) = untrie ta `either` untrie tb+--   enumerate (ta :*: tb) = enum' Left ta `weave` enum' Right tb++-- enum' :: HasLub(b) => 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)++-- To do: rethink enumerate and come back to it.  How might enumeration+-- work in the presence of nonstrict memo tries?  Maybe lub the+-- approximation into each of the values enumerated from the strict memo tries.+-- Would it help any??++instance (HF(a), HasTrie b) => HasTrie (a , b) where+  type STrie (a , b) = Trie a :. Trie b+--   sTrie   f = O (trie (trie . curry f))+--   sUntrie (O tt) = uncurry (untrie . untrie tt)+  sTrie   f = O (fmap trie (trie (curry f)))+  sUntrie (O tt) = uncurry (untrie (fmap untrie tt))++--   enumerate (O tt) =+--     [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ]++-- With the first definitions of sTrie and sUntrie:+-- +--     Could not deduce (HasLub (Trie b v)) from the context (HasLub v)+--       arising from a use of `trie'+-- +--     Could not deduce (HasLub (Trie b v)) from the context (HasLub v)+--       arising from a use of `untrie'+-- +-- Solution: switch from inner-then-outer to outer-then-inner.++#define HasTrieIsomorph(Context,Type,IsoType,toIso,fromIso) \+instance Context => HasTrie (Type) where { \+  type STrie (Type) = STrie (IsoType); \+  sTrie f = sTrie (f . (fromIso)); \+  sUntrie t = sUntrie t . (toIso); \+}++  -- enumerate = (result.fmap.first) (fromIso) enumerate; \+++HasTrieIsomorph( (), Bool, Either () ()+               , bool (Left ()) (Right ())+               , either (\ () -> True) (\ () -> False))++HasTrieIsomorph( (HF(a),HF(b), HasTrie c)+               , (a,b,c), ((a,b),c)+               , \ (a,b,c) -> ((a,b),c), \ ((a,b),c) -> (a,b,c))++HasTrieIsomorph( (HF(a),HF(b),HF(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( ( HF(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 )+++newtype ListSTrie a v = ListSTrie (PF [a] [a] :-> v)+ +deriving instance Functor (STrie a) => Functor (ListSTrie a)+ +instance (HF(a)) => HasTrie [a] where+  type STrie [a] = ListSTrie a+  sTrie f = ListSTrie (sTrie (f . wrap))+  sUntrie (ListSTrie t) = sUntrie t . unwrap+  -- enumerate (ListSTrie t) = (result.fmap.first) wrap enumerate $ t++-- Compiles fine, but has many points of undefinedness than a list does.+-- Experiment with some alternatives.++++-- Now a trie for ListSTrie a v.  Use the isomorphism with PF [a] [a] :-> v++-- HasTrieIsomorph( HasTrie (PF ([a]) ([a]) :->: v)+--                , ListSTrie a v, PF ([a]) ([a]) :->: v+--                , \ (ListSTrie w) -> w, ListSTrie )+++-- instance HasTrie (PF ([a]) ([a]) :->: v) => HasTrie (ListSTrie a v) where+--   type STrie (ListSTrie a v) = STrie (PF ([a]) ([a]) :->: v)+--   sTrie f = sTrie (f . ListSTrie)+--   -- sUntrie t = sUntrie t . (\ (ListSTrie w) -> w)+++--     Could not deduce (HasTrie (Trie ((:*:) (Const a) Id [a]) v),+--                       Functor (STrie (Trie (Const () [a]) v)),+--                       HasTrie (Trie (Const () [a]) v))+--       from the context (HasLub v1)+--       arising from a use of `sTrie'++--     Couldn't match expected type `STrie+--                                     (Trie ((:+:) Unit (Const a :*: Id) [a]) v)'+--            against inferred type `Trie (Trie (Const () [a]) v)+--                                   :. Trie (Trie ((:*:) (Const a) Id [a]) v)'+--       NB: `STrie' is a type function, and may not be injective+--     In the expression: sTrie (f . ListSTrie)++{-++f :: ListSTrie a v -> u++ListSTrie :: (PF [a] [a] :-> v) -> ListSTrie a v++f . ListSTrie :: (PF [a] [a] :-> v) -> u++sTrie (f . ListSTrie) :: HasTrie (PF [a] [a] :-> v) => (PF [a] [a] :-> v) :-> u+                     :: HasTrie (PF [a] [a] :-> v) => ListSTrie a v :-> u++ListSTrie a v :-> u++(PF [a] [a] :-> v) :-> u++((Unit :+: Const a :*: Id) [a] :-> v) :-> u++(Either (Unit [a]) ((Const a :*: Id) [a]) :-> v) :-> u++STrie (Either (Unit [a]) ((Const a :*: Id) [a])) v :-> u++(Trie (Unit [a]) :*: Trie ((Const a :*: Id) [a])) v :-> u++(Trie (Unit [a]) v , Trie ((Const a :*: Id) [a]) v) :-> u++(Unit [a] :->: v , (Const a :*: Id) [a] :->: v) :-> u++STrie (Unit [a] :->: v , (Const a :*: Id) [a] :->: v) u++(Trie (Unit [a] :->: v) :. Trie ((Const a :*: Id) [a] :->: v)) u++(Trie (Unit [a] :->: v) :. Trie ((Const a [a], Id [a]) :->: v)) u++(Trie (Unit [a] :->: v) :. Trie ((Const a [a], Id [a]) :->: v)) u+++(v , (Const a [a], Id [a]) :-> v)++(v , Const a [a] :->: Id [a] :->: v)++(v , (Id [a] :->: v, Const a [a] :-> Id [a] :->: v))++(v , (Id [a] :->: v, Const a [a] :-> (v, Id [a] :-> v)))++(v , ((v, Id [a] :-> v), Const a [a] :-> (v, Id [a] :-> v)))++(v , ((v, [a] :->: v), a :->: (v, [a] :->: v)))++++ListSTrie a v++PF [a] [a] :-> v++(Unit :+: Const a :*: Id) [a] :-> v++Either (Unit [a]) ((Const a :*: Id) [a]) :-> v++STrie (Either (Unit [a]) ((Const a :*: Id) [a])) v++(Trie (Unit [a]) :*: Trie ((Const a :*: Id) [a])) v+++-}++++{-++-- 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 STrie (Type) = TrieType; \+  sTrie f = TrieCon (sTrie (f . wrap)); \+  sUntrie (TrieCon t) = sUntrie t . unwrap; \+}; \+HasTrieIsomorph( HasTrie (PF (Type) (Type) :->: v) \+               , TrieType v, PF (Type) (Type) :->: v \+               , \ (TrieCon w) -> w, TrieCon )++--   enumerate (TrieCon t) = (result.fmap.first) wrap enumerate t; \++++-- For instance,++-- HasTrieRegular(HasTrie a, [a]   , ListSTrie a, ListSTrie)+-- HasTrieRegular(HasTrie a, Tree a, 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([]  , ListSTrie)+-- HasTrieRegular1(Tree, TreeTrie)+++-- HasTrieIsomorph(Context,Type,IsoType,toIso,fromIso)++-- HasTrieIsomorph( HasTrie (PF [a] [a] :->: v)+--                , ListSTrie a v, PF [a] [a] :->: v+--                , \ (ListSTrie w) -> w, ListSTrie )+++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 STrie Type = IT.IntTrie; \+  sTrie   = (<$> IT.identity); \+  sUntrie = IT.apply; \+  enumerate = enumerateEnum; \+}++HasTrieIntegral(Int)+HasTrieIntegral(Integer)+++-- Memoizing higher-order functions++HasTrieIsomorph((HasTrie a, HasTrie (a :->: b)), a -> b, a :->: b, trie, untrie)+++{-++{--------------------------------------------------------------------+    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]+ft1 f = [f False, f True]++f1 :: Bool -> Int+f1 False = 0+f1 True  = 1++trie1a :: HasTrie a => (Bool -> a) :->: [a]+trie1a = trie ft1++trie1b :: HasTrie a => (Bool :->: a) :->: [a]+trie1b = trie1a++trie1c :: HasTrie a => (Either () () :->: a) :->: [a]+trie1c = trie1a++trie1d :: HasTrie a => ((Trie () :*: Trie ()) a) :->: [a]+trie1d = trie1a++trie1e :: HasTrie a => (Trie () a, Trie () a) :->: [a]+trie1e = trie1a++trie1f :: HasTrie a => (() :->: a, () :->: a) :->: [a]+trie1f = trie1a++trie1g :: HasTrie a => (a, a) :->: [a]+trie1g = trie1a++trie1h :: HasTrie a => (Trie a :. Trie a) [a]+trie1h = trie1a++trie1i :: HasTrie a => a :->: a :->: [a]+trie1i = unO trie1a+++ft2 :: ([Bool] -> Int) -> Int+ft2 f = f (alts 15)++alts :: Int -> [Bool]+alts n = take n (cycle [True,False])++f2 :: [Bool] -> Int+f2 = length . filter id++-- Memoization fails:++-- *FunctorCombo.MemoTrie> ft2 f2+-- 8+-- *FunctorCombo.MemoTrie> memo ft2 f2+-- ... (hang forever) ...++-- Would nonstrict memoization work?  <http://conal.net/blog/posts/nonstrict-memoization/>++f3 :: Bool -> Integer+f3 = const 3++-- *FunctorCombo.MemoTrie> f3 undefined+-- 3+-- *FunctorCombo.MemoTrie> memo f3 undefined+-- *** Exception: Prelude.undefined++f4 :: () -> Integer+f4 = const 4++-- *FunctorCombo.MemoTrie> f4 undefined+-- 4+-- *FunctorCombo.MemoTrie> memo f4 undefined+-- 4++f5 :: ((),()) -> Integer+f5 = const 5++-- *FunctorCombo.MemoTrie> f5 undefined+-- 5+-- *FunctorCombo.MemoTrie> memo f5 undefined+-- 5++f6 :: Either () () -> Integer+f6 = const 6++-- *FunctorCombo.MemoTrie> f6 undefined+-- 6+-- *FunctorCombo.MemoTrie> memo f6 undefined+-- *** Exception: Prelude.undefined++-- Aha!++t6 :: Either () () :-> Integer+t6 = trie f6++-- *FunctorCombo.MemoTrie> t6+-- Id 6 :*: Id 6++-}