diff --git a/functor-combo.cabal b/functor-combo.cabal --- a/functor-combo.cabal +++ b/functor-combo.cabal @@ -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 diff --git a/src/FunctorCombo/DHoley.hs b/src/FunctorCombo/DHoley.hs --- a/src/FunctorCombo/DHoley.hs +++ b/src/FunctorCombo/DHoley.hs @@ -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 -} diff --git a/src/FunctorCombo/FixC.hs b/src/FunctorCombo/FixC.hs --- a/src/FunctorCombo/FixC.hs +++ b/src/FunctorCombo/FixC.hs @@ -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 diff --git a/src/FunctorCombo/Functor.hs b/src/FunctorCombo/Functor.hs --- a/src/FunctorCombo/Functor.hs +++ b/src/FunctorCombo/Functor.hs @@ -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 . +-- +-- 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 diff --git a/src/FunctorCombo/Holey.hs b/src/FunctorCombo/Holey.hs --- a/src/FunctorCombo/Holey.hs +++ b/src/FunctorCombo/Holey.hs @@ -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 -} diff --git a/src/FunctorCombo/LocT.hs b/src/FunctorCombo/LocT.hs --- a/src/FunctorCombo/LocT.hs +++ b/src/FunctorCombo/LocT.hs @@ -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)) {- diff --git a/src/FunctorCombo/Lub.hs b/src/FunctorCombo/Lub.hs new file mode 100644 --- /dev/null +++ b/src/FunctorCombo/Lub.hs @@ -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. diff --git a/src/FunctorCombo/MemoTrie.hs b/src/FunctorCombo/MemoTrie.hs --- a/src/FunctorCombo/MemoTrie.hs +++ b/src/FunctorCombo/MemoTrie.hs @@ -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? + +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 -} diff --git a/src/FunctorCombo/NonstrictMemo.hs b/src/FunctorCombo/NonstrictMemo.hs new file mode 100644 --- /dev/null +++ b/src/FunctorCombo/NonstrictMemo.hs @@ -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? + +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 + +-}