├── .gitignore ├── COPYING ├── Makefile ├── MemoTrie.cabal ├── README.md ├── Setup.lhs ├── changes.tw ├── examples └── Generic.hs ├── src └── Data │ └── MemoTrie.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | Junk* 3 | Old* 4 | dist 5 | Stuff 6 | TAGS 7 | tags 8 | tarballs 9 | 10 | # Mac OS generates 11 | .DS_Store 12 | 13 | # Where do these files come from? They're not readable. 14 | # For instance, .#Help.page 15 | .#* 16 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Conal Elliott 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The names of the authors may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include ../my-cabal-make.inc 2 | -------------------------------------------------------------------------------- /MemoTrie.cabal: -------------------------------------------------------------------------------- 1 | Name: MemoTrie 2 | Version: 0.6.11 3 | Cabal-Version: >= 1.10 4 | Synopsis: Trie-based memo functions 5 | Category: Data 6 | Description: 7 | MemoTrie provides a basis for memoized functions over some domains, 8 | using tries. It's based on ideas from Ralf Hinze and code from 9 | Spencer Janssen. Generic support thanks to Sam Boosalis. 10 | . 11 | Project wiki page: 12 | . 13 | © 2008-2019 by Conal Elliott; BSD3 license. 14 | Homepage: https://github.com/conal/MemoTrie 15 | Author: Conal Elliott 16 | Maintainer: conal@conal.net 17 | Copyright: (c) 2008-2019 by Conal Elliott 18 | License: BSD3 19 | License-File: COPYING 20 | Stability: experimental 21 | build-type: Simple 22 | 23 | source-repository head 24 | type: git 25 | location: git://github.com/conal/MemoTrie.git 26 | 27 | Flag examples 28 | Description: "examples" 29 | Default: False 30 | Manual: True 31 | 32 | Library 33 | hs-Source-Dirs: src 34 | 35 | if impl(ghc >= 7.10.0) 36 | Build-Depends: base >=4.8.0.0 && <5, newtype-generics >= 0.5.3 37 | else 38 | Build-Depends: base <4.8.0.0, void, newtype-generics >= 0.5.3 39 | 40 | Exposed-Modules: 41 | Data.MemoTrie 42 | Other-Modules: 43 | 44 | default-language: Haskell2010 45 | 46 | executable generic 47 | if !flag(examples) 48 | buildable: False 49 | main-is: Generic.hs 50 | ghc-options: -Wall 51 | hs-source-dirs: examples 52 | default-language: Haskell2010 53 | build-depends: base, MemoTrie 54 | 55 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | *MemoTrie* is functional library for creating efficient memo functions, using [tries](http://en.wikipedia.org/wiki/Trie "http://en.wikipedia.org/wiki/Trie"). 2 | It's based on some code from Spencer Janssen (originally put on hpaste.org, now expired), which I assume was based on Ralf Hinze's paper [*Memo functions, polytypically!*](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.43.3272 "http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.43.3272"). 3 | 4 | Install with `cabal install Memotrie`. 5 | 6 | See also 7 | 8 | * Library documentation [on Hackage](http://hackage.haskell.org/package/MemoTrie). 9 | * Related [blog posts](http://conal.net/blog/tag/trie/ "http://conal.net/blog/tag/trie/"). 10 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /changes.tw: -------------------------------------------------------------------------------- 1 | == Version 0 == 2 | 3 | === Version 0.0 === 4 | 5 | * Created. Extracted from vector-space. 6 | -------------------------------------------------------------------------------- /examples/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, TypeOperators, TypeFamilies #-} 2 | import Data.MemoTrie 3 | import GHC.Generics (Generic) 4 | 5 | data Color = RGB Int Int Int 6 | | NamedColor String 7 | deriving (Generic) 8 | 9 | instance HasTrie Color where 10 | newtype (Color :->: b) = ColorTrie { unColorTrie :: Reg Color :->: b } 11 | trie = trieGeneric ColorTrie 12 | untrie = untrieGeneric unColorTrie 13 | enumerate = enumerateGeneric unColorTrie 14 | 15 | runColor (RGB r g b) = r + g + b 16 | runColor (NamedColor s) = length [1..10e7] 17 | 18 | runColorMemoized = memo runColor 19 | 20 | main = 21 | do putStrLn "first call (should take a few seconds): " 22 | print$ runColorMemoized (NamedColor "") 23 | putStrLn "cached call (should be instantaneous): " 24 | print$ runColorMemoized (NamedColor "") 25 | 26 | -------------------------------------------------------------------------------- /src/Data/MemoTrie.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeFamilies, TypeOperators, ScopedTypeVariables, CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# OPTIONS_GHC -Wall -fenable-rewrite-rules #-} 5 | 6 | -- ScopedTypeVariables works around a 6.10 bug. The forall keyword is 7 | -- supposed to be recognized in a RULES pragma. 8 | 9 | ---------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.MemoTrie 12 | -- Copyright : (c) Conal Elliott 2008-2016 13 | -- License : BSD3 14 | -- 15 | -- Maintainer : conal@conal.net 16 | -- Stability : experimental 17 | -- 18 | -- Trie-based memoizer 19 | -- 20 | -- Adapted from sjanssen's paste: , 21 | -- which I think is based on Ralf Hinze's paper "Memo Functions, 22 | -- Polytypically!". 23 | -- 24 | -- You can automatically derive generic instances. for example: 25 | -- 26 | -- @ 27 | -- {-# LANGUAGE , TypeOperators, TypeFamilies #-} 28 | -- import Data.MemoTrie 29 | -- import GHC.Generics (Generic) 30 | -- 31 | -- data Color = RGB Int Int Int 32 | -- | NamedColor String 33 | -- deriving ('Generic') 34 | -- 35 | -- instance HasTrie Color where 36 | -- newtype (Color :->: b) = ColorTrie { unColorTrie :: 'Reg' Color :->: b } 37 | -- trie = 'trieGeneric' ColorTrie 38 | -- untrie = 'untrieGeneric' unColorTrie 39 | -- enumerate = 'enumerateGeneric' unColorTrie 40 | -- @ 41 | -- 42 | -- see @examples/Generic.hs@, which can be run with: 43 | -- 44 | -- @ 45 | -- cabal configure -fexamples && cabal run generic 46 | -- @ 47 | -- 48 | -- 49 | ---------------------------------------------------------------------- 50 | 51 | module Data.MemoTrie 52 | ( HasTrie(..), (:->:)(..) 53 | , domain, idTrie, (@.@) 54 | -- , trie2, trie3, untrie2, untrie3 55 | , memo, memo2, memo3, mup 56 | , inTrie, inTrie2, inTrie3 57 | -- , untrieBits 58 | , trieGeneric, untrieGeneric, enumerateGeneric, Reg 59 | , memoFix 60 | ) where 61 | 62 | -- Export the parts of HasTrie separately in order to get the associated data 63 | -- type constructors, so I can define instances of other classes on them. 64 | 65 | import Data.Bits 66 | import Data.Word 67 | import Data.Int 68 | #if !MIN_VERSION_base(4,8,0) 69 | import Control.Applicative 70 | #endif 71 | import Control.Arrow (first,(&&&)) 72 | #if !MIN_VERSION_base(4,8,0) 73 | import Data.Monoid 74 | #endif 75 | import Data.Function (fix, on) 76 | import GHC.Generics 77 | 78 | import Control.Newtype.Generics 79 | 80 | import Data.Void (Void) 81 | 82 | -- import Prelude hiding (id,(.)) 83 | -- import Control.Category 84 | -- import Control.Arrow 85 | 86 | infixr 0 :->: 87 | 88 | -- | Mapping from all elements of @a@ to the results of some function 89 | class HasTrie a where 90 | -- | Representation of trie with domain type @a@ 91 | data (:->:) a :: * -> * 92 | -- | Create the trie for the entire domain of a function 93 | trie :: (a -> b) -> (a :->: b) 94 | -- | Convert a trie to a function, i.e., access a field of the trie 95 | untrie :: (a :->: b) -> (a -> b) 96 | -- | List the trie elements. Order of keys (@:: a@) is always the same. 97 | enumerate :: (a :->: b) -> [(a,b)] 98 | 99 | -- | Domain elements of a trie 100 | domain :: HasTrie a => [a] 101 | domain = map fst (enumerate (trie (const oops))) 102 | where 103 | oops = error "Data.MemoTrie.domain: range element evaluated." 104 | 105 | -- Hm: domain :: [Bool] doesn't produce any output. 106 | 107 | instance (HasTrie a, Eq b) => Eq (a :->: b) where 108 | (==) = (==) `on` (map snd . enumerate) 109 | 110 | instance (HasTrie a, Show a, Show b) => Show (a :->: b) where 111 | show t = "Trie: " ++ show (enumerate t) 112 | 113 | {- 114 | trie2 :: (HasTrie a, HasTrie b) => 115 | (a -> b -> c) -> (a :->: b :->: c) 116 | -- trie2 h = trie $ \ a -> trie $ \ b -> h a b 117 | -- trie2 h = trie $ \ a -> trie (h a) 118 | trie2 h = trie (trie . h) 119 | -- trie2 h = trie (fmap trie h) 120 | -- trie2 = (fmap.fmap) trie trie 121 | 122 | 123 | trie3 :: (HasTrie a, HasTrie b, HasTrie c) => 124 | (a -> b -> c -> d) -> (a :->: b :->: c :->: d) 125 | trie3 h = trie (trie2 . h) 126 | 127 | untrie2 :: (HasTrie a, HasTrie b) => 128 | (a :->: b :->: c)-> (a -> b -> c) 129 | untrie2 tt = untrie . untrie tt 130 | 131 | 132 | untrie3 :: (HasTrie a, HasTrie b, HasTrie c) => 133 | (a :->: b :->: c :->: d)-> (a -> b -> c -> d) 134 | untrie3 tt = untrie2 . untrie tt 135 | -} 136 | 137 | 138 | -- {-# RULES "trie/untrie" forall t. trie (untrie t) = t #-} 139 | 140 | -- warning: [-Winline-rule-shadowing] … 141 | -- Rule "trie/untrie" may never fire 142 | -- because rule "Class op untrie" for ‘untrie’ might fire first 143 | -- Probable fix: add phase [n] or [~n] to the competing rule 144 | 145 | 146 | -- Don't include the dual rule: 147 | -- "untrie/trie" forall f. untrie (trie f) = f 148 | -- which would defeat memoization. 149 | -- 150 | -- TODO: experiment with rule application. Maybe re-enable "untrie/trie" 151 | -- but fiddle with phases, so it won't defeat 'memo'. 152 | 153 | -- | Trie-based function memoizer 154 | memo :: HasTrie t => (t -> a) -> (t -> a) 155 | memo = untrie . trie 156 | 157 | -- | Memoize a binary function, on its first argument and then on its 158 | -- second. Take care to exploit any partial evaluation. 159 | memo2 :: (HasTrie s,HasTrie t) => (s -> t -> a) -> (s -> t -> a) 160 | 161 | -- | Memoize a ternary function on successive arguments. Take care to 162 | -- exploit any partial evaluation. 163 | memo3 :: (HasTrie r,HasTrie s,HasTrie t) => (r -> s -> t -> a) -> (r -> s -> t -> a) 164 | 165 | -- | Lift a memoizer to work with one more argument. 166 | mup :: HasTrie t => (b -> c) -> (t -> b) -> (t -> c) 167 | mup mem f = memo (mem . f) 168 | 169 | memo2 = mup memo 170 | memo3 = mup memo2 171 | 172 | -- | Memoizing recursion. Use like `fix`. 173 | memoFix :: HasTrie a => ((a -> b) -> (a -> b)) -> (a -> b) 174 | memoFix h = fix (memo . h) 175 | 176 | #if 0 177 | -- Equivalently, 178 | 179 | memoFix h = fix (\ f' -> memo (h f')) 180 | 181 | memoFix h = f' 182 | where f' = memo (h f') 183 | 184 | memoFix h = f' 185 | where 186 | f' = memo f 187 | f = h f' 188 | #endif 189 | 190 | #if 0 191 | -- Example 192 | 193 | fibF :: (Integer -> Integer) -> (Integer -> Integer) 194 | fibF _ 0 = 1 195 | fibF _ 1 = 1 196 | fibF f n = f (n-1) + f (n-2) 197 | 198 | fib :: Integer -> Integer 199 | fib = fix fibF 200 | 201 | fib' :: Integer -> Integer 202 | fib' = memoFix fibF 203 | 204 | -- Try fib 30 vs fib' 30 205 | #endif 206 | 207 | 208 | -- | Apply a unary function inside of a trie 209 | inTrie :: (HasTrie a, HasTrie c) => 210 | ((a -> b) -> (c -> d)) 211 | -> ((a :->: b) -> (c :->: d)) 212 | inTrie = untrie ~> trie 213 | 214 | -- | Apply a binary function inside of a trie 215 | inTrie2 :: (HasTrie a, HasTrie c, HasTrie e) => 216 | ((a -> b) -> (c -> d) -> (e -> f)) 217 | -> ((a :->: b) -> (c :->: d) -> (e :->: f)) 218 | inTrie2 = untrie ~> inTrie 219 | 220 | -- | Apply a ternary function inside of a trie 221 | inTrie3 :: (HasTrie a, HasTrie c, HasTrie e, HasTrie g) => 222 | ((a -> b) -> (c -> d) -> (e -> f) -> (g -> h)) 223 | -> ((a :->: b) -> (c :->: d) -> (e :->: f) -> (g :->: h)) 224 | inTrie3 = untrie ~> inTrie2 225 | 226 | 227 | ---- Instances 228 | 229 | instance HasTrie Void where 230 | -- As suggested by Audun Skaugen 231 | data Void :->: a = VoidTrie 232 | trie _ = VoidTrie 233 | untrie VoidTrie = \ _ -> error "untrie VoidTrie" 234 | -- \case -- needs EmptyCase 235 | enumerate VoidTrie = [] 236 | 237 | instance Newtype (Void :->: a) where 238 | type O (Void :->: a) = () 239 | pack () = VoidTrie 240 | unpack VoidTrie = () 241 | 242 | instance HasTrie () where 243 | newtype () :->: a = UnitTrie a 244 | trie f = UnitTrie (f ()) 245 | untrie (UnitTrie a) = \ () -> a 246 | enumerate (UnitTrie a) = [((),a)] 247 | 248 | instance Newtype (() :->: a) where 249 | type O (() :->: a) = a 250 | pack a = UnitTrie a 251 | unpack (UnitTrie a) = a 252 | 253 | -- Proofs of inverse properties: 254 | 255 | {- 256 | untrie (trie f) 257 | == { trie def } 258 | untrie (UnitTrie (f ())) 259 | == { untrie def } 260 | \ () -> (f ()) 261 | == { const-unit } 262 | f 263 | 264 | trie (untrie (UnitTrie a)) 265 | == { untrie def } 266 | trie (\ () -> a) 267 | == { trie def } 268 | UnitTrie ((\ () -> a) ()) 269 | == { beta-reduction } 270 | UnitTrie a 271 | 272 | Oops -- the last step of the first direction is bogus when f is non-strict. 273 | Can be fixed by using @const a@ in place of @\ () -> a@, but I can't do 274 | the same for other types, like integers or sums. 275 | 276 | All of these proofs have this same bug, unless we restrict ourselves to 277 | memoizing hyper-strict functions. 278 | 279 | -} 280 | 281 | 282 | instance HasTrie Bool where 283 | data Bool :->: x = BoolTrie x x 284 | trie f = BoolTrie (f False) (f True) 285 | untrie (BoolTrie f t) = if' f t 286 | enumerate (BoolTrie f t) = [(False,f),(True,t)] 287 | 288 | instance Newtype (Bool :->: a) where 289 | type O (Bool :->: a) = (a,a) 290 | pack (a,a') = BoolTrie a a' 291 | unpack (BoolTrie a a') = (a,a') 292 | 293 | -- | Conditional with boolean last. 294 | -- Spec: @if' (f False) (f True) == f@ 295 | if' :: x -> x -> Bool -> x 296 | if' t _ False = t 297 | if' _ e True = e 298 | 299 | {- 300 | untrie (trie f) 301 | == { trie def } 302 | untrie (BoolTrie (f False) (f True)) 303 | == { untrie def } 304 | if' (f False) (f True) 305 | == { if' spec } 306 | f 307 | 308 | trie (untrie (BoolTrie f t)) 309 | == { untrie def } 310 | trie (if' f t) 311 | == { trie def } 312 | BoolTrie (if' f t False) (if' f t True) 313 | == { if' spec } 314 | BoolTrie f t 315 | -} 316 | 317 | instance HasTrie a => HasTrie (Maybe a) where 318 | data (:->:) (Maybe a) b = MaybeTrie b (a :->: b) 319 | trie f = MaybeTrie (f Nothing) (trie (f . Just)) 320 | untrie (MaybeTrie nothing_val a_trie) = maybe nothing_val (untrie a_trie) 321 | enumerate (MaybeTrie nothing_val a_trie) = (Nothing, nothing_val) : enum' Just a_trie 322 | 323 | instance Newtype (Maybe a :->: x) where 324 | type O (Maybe a :->: x) = (x, a :->: x) 325 | pack (a,f) = MaybeTrie a f 326 | unpack (MaybeTrie a f) = (a,f) 327 | 328 | instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where 329 | data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x) 330 | trie f = EitherTrie (trie (f . Left)) (trie (f . Right)) 331 | untrie (EitherTrie s t) = either (untrie s) (untrie t) 332 | enumerate (EitherTrie s t) = enum' Left s `weave` enum' Right t 333 | 334 | instance Newtype (Either a b :->: x) where 335 | type O (Either a b :->: x) = (a :->: x, b :->: x) 336 | pack (f,g) = EitherTrie f g 337 | unpack (EitherTrie f g) = (f,g) 338 | 339 | enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)] 340 | enum' f = (fmap.first) f . enumerate 341 | 342 | weave :: [a] -> [a] -> [a] 343 | [] `weave` as = as 344 | as `weave` [] = as 345 | (a:as) `weave` bs = a : (bs `weave` as) 346 | 347 | {- 348 | untrie (trie f) 349 | == { trie def } 350 | untrie (EitherTrie (trie (f . Left)) (trie (f . Right))) 351 | == { untrie def } 352 | either (untrie (trie (f . Left))) (untrie (trie (f . Right))) 353 | == { untrie . trie } 354 | either (f . Left) (f . Right) 355 | == { either } 356 | f 357 | 358 | trie (untrie (EitherTrie s t)) 359 | == { untrie def } 360 | trie (either (untrie s) (untrie t)) 361 | == { trie def } 362 | EitherTrie (trie (either (untrie s) (untrie t) . Left)) 363 | (trie (either (untrie s) (untrie t) . Right)) 364 | == { either } 365 | EitherTrie (trie (untrie s)) (trie (untrie t)) 366 | == { trie . untrie } 367 | EitherTrie s t 368 | -} 369 | 370 | 371 | instance (HasTrie a, HasTrie b) => HasTrie (a,b) where 372 | newtype (a,b) :->: x = PairTrie (a :->: (b :->: x)) 373 | trie f = PairTrie (trie (trie . curry f)) 374 | untrie (PairTrie t) = uncurry (untrie . untrie t) 375 | enumerate (PairTrie tt) = 376 | [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ] 377 | 378 | instance Newtype ((a,b) :->: x) where 379 | type O ((a,b) :->: x) = a :->: b :->: x 380 | pack abx = PairTrie abx 381 | unpack (PairTrie abx) = abx 382 | 383 | {- 384 | untrie (trie f) 385 | == { trie def } 386 | untrie (PairTrie (trie (trie . curry f))) 387 | == { untrie def } 388 | uncurry (untrie . untrie (trie (trie . curry f))) 389 | == { untrie . trie } 390 | uncurry (untrie . trie . curry f) 391 | == { untrie . untrie } 392 | uncurry (curry f) 393 | == { uncurry . curry } 394 | f 395 | 396 | trie (untrie (PairTrie t)) 397 | == { untrie def } 398 | trie (uncurry (untrie . untrie t)) 399 | == { trie def } 400 | PairTrie (trie (trie . curry (uncurry (untrie . untrie t)))) 401 | == { curry . uncurry } 402 | PairTrie (trie (trie . untrie . untrie t)) 403 | == { trie . untrie } 404 | PairTrie (trie (untrie t)) 405 | == { trie . untrie } 406 | PairTrie t 407 | -} 408 | 409 | instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where 410 | newtype (a,b,c) :->: x = TripleTrie (((a,b),c) :->: x) 411 | trie f = TripleTrie (trie (f . trip)) 412 | untrie (TripleTrie t) = untrie t . detrip 413 | enumerate (TripleTrie t) = enum' trip t 414 | 415 | trip :: ((a,b),c) -> (a,b,c) 416 | trip ((a,b),c) = (a,b,c) 417 | 418 | detrip :: (a,b,c) -> ((a,b),c) 419 | detrip (a,b,c) = ((a,b),c) 420 | 421 | 422 | instance HasTrie x => HasTrie [x] where 423 | newtype [x] :->: a = ListTrie (Either () (x,[x]) :->: a) 424 | trie f = ListTrie (trie (f . list)) 425 | untrie (ListTrie t) = untrie t . delist 426 | enumerate (ListTrie t) = enum' list t 427 | 428 | list :: Either () (x,[x]) -> [x] 429 | list = either (const []) (uncurry (:)) 430 | 431 | delist :: [x] -> Either () (x,[x]) 432 | delist [] = Left () 433 | delist (x:xs) = Right (x,xs) 434 | 435 | #define WordInstance(Type,TrieType)\ 436 | instance HasTrie Type where \ 437 | newtype Type :->: a = TrieType ([Bool] :->: a);\ 438 | trie f = TrieType (trie (f . unbits));\ 439 | untrie (TrieType t) = untrie t . bits;\ 440 | enumerate (TrieType t) = enum' unbits t 441 | 442 | WordInstance(Word,WordTrie) 443 | WordInstance(Word8,Word8Trie) 444 | WordInstance(Word16,Word16Trie) 445 | WordInstance(Word32,Word32Trie) 446 | WordInstance(Word64,Word64Trie) 447 | 448 | -- instance HasTrie Word where 449 | -- newtype Word :->: a = WordTrie ([Bool] :->: a) 450 | -- trie f = WordTrie (trie (f . unbits)) 451 | -- untrie (WordTrie t) = untrie t . bits 452 | -- enumerate (WordTrie t) = enum' unbits t 453 | 454 | 455 | -- | Extract bits in little-endian order 456 | bits :: (Num t, Bits t) => t -> [Bool] 457 | bits 0 = [] 458 | bits x = testBit x 0 : bits (shiftR x 1) 459 | 460 | -- | Convert boolean to 0 (False) or 1 (True) 461 | unbit :: Num t => Bool -> t 462 | unbit False = 0 463 | unbit True = 1 464 | 465 | -- | Bit list to value 466 | unbits :: (Num t, Bits t) => [Bool] -> t 467 | unbits [] = 0 468 | unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1 469 | 470 | instance HasTrie Char where 471 | newtype Char :->: a = CharTrie (Int :->: a) 472 | untrie (CharTrie t) n = untrie t (fromEnum n) 473 | trie f = CharTrie (trie (f . toEnum)) 474 | enumerate (CharTrie t) = enum' toEnum t 475 | 476 | -- Although Int is a Bits instance, we can't use bits directly for 477 | -- memoizing, because the "bits" function gives an infinite result, since 478 | -- shiftR (-1) 1 == -1. Instead, convert between Int and Word, and use 479 | -- a Word trie. Any Integral type can be handled similarly. 480 | 481 | #define IntInstance(IntType,WordType,TrieType) \ 482 | instance HasTrie IntType where \ 483 | newtype IntType :->: a = TrieType (WordType :->: a); \ 484 | untrie (TrieType t) n = untrie t (fromIntegral n); \ 485 | trie f = TrieType (trie (f . fromIntegral)); \ 486 | enumerate (TrieType t) = enum' fromIntegral t 487 | 488 | IntInstance(Int,Word,IntTrie) 489 | IntInstance(Int8,Word8,Int8Trie) 490 | IntInstance(Int16,Word16,Int16Trie) 491 | IntInstance(Int32,Word32,Int32Trie) 492 | IntInstance(Int64,Word64,Int64Trie) 493 | 494 | -- For unbounded integers, we don't have a corresponding Word type, so 495 | -- extract the sign bit. 496 | 497 | instance HasTrie Integer where 498 | newtype Integer :->: a = IntegerTrie ((Bool,[Bool]) :->: a) 499 | trie f = IntegerTrie (trie (f . unbitsZ)) 500 | untrie (IntegerTrie t) = untrie t . bitsZ 501 | enumerate (IntegerTrie t) = enum' unbitsZ t 502 | 503 | 504 | unbitsZ :: (Num n, Bits n) => (Bool,[Bool]) -> n 505 | unbitsZ (positive,bs) = sig (unbits bs) 506 | where 507 | sig | positive = id 508 | | otherwise = negate 509 | 510 | bitsZ :: (Num n, Ord n, Bits n) => n -> (Bool,[Bool]) 511 | bitsZ = (>= 0) &&& (bits . abs) 512 | 513 | -- TODO: make these definitions more systematic. 514 | 515 | 516 | ---- Instances 517 | 518 | {- 519 | 520 | The \"semantic function\" 'untrie' is a morphism over 'Monoid', 'Functor', 521 | 'Applicative', 'Monad', 'Category', and 'Arrow', i.e., 522 | 523 | untrie mempty == mempty 524 | untrie (s `mappend` t) == untrie s `mappend` untrie t 525 | 526 | untrie (fmap f t) == fmap f (untrie t) 527 | 528 | untrie (pure a) == pure a 529 | untrie (tf <*> tx) == untrie tf <*> untrie tx 530 | 531 | untrie (return a) == return a 532 | untrie (u >>= k) == untrie u >>= untrie . k 533 | 534 | untrie id == id 535 | untrie (s . t) == untrie s . untrie t 536 | 537 | untrie (arr f) == arr f 538 | untrie (first t) == first (untrie t) 539 | 540 | These morphism properties imply that all of the expected laws hold, 541 | assuming that we interpret equality semantically (or observationally). 542 | For instance, 543 | 544 | untrie (mempty `mappend` a) 545 | == untrie mempty `mappend` untrie a 546 | == mempty `mappend` untrie a 547 | == untrie a 548 | 549 | untrie (fmap f (fmap g a)) 550 | == fmap f (untrie (fmap g a)) 551 | == fmap f (fmap g (untrie a)) 552 | == fmap (f.g) (untrie a) 553 | == untrie (fmap (f.g) a) 554 | 555 | The implementation instances then follow from applying 'trie' to both 556 | sides of each of these morphism laws. 557 | 558 | -} 559 | 560 | {- 561 | instance (HasTrie a, Monoid b) => Monoid (a :->: b) where 562 | mempty = trie mempty 563 | s `mappend` t = trie (untrie s `mappend` untrie t) 564 | 565 | instance HasTrie a => Functor ((:->:) a) where 566 | fmap f t = trie (fmap f (untrie t)) 567 | 568 | instance HasTrie a => Applicative ((:->:) a) where 569 | pure b = trie (pure b) 570 | tf <*> tx = trie (untrie tf <*> untrie tx) 571 | 572 | instance HasTrie a => Monad ((:->:) a) where 573 | return a = trie (return a) 574 | u >>= k = trie (untrie u >>= untrie . k) 575 | 576 | -- instance Category (:->:) where 577 | -- id = trie id 578 | -- s . t = trie (untrie s . untrie t) 579 | 580 | -- instance Arrow (:->:) where 581 | -- arr f = trie (arr f) 582 | -- first t = trie (first (untrie t)) 583 | -} 584 | 585 | -- Simplify, using inTrie, inTrie2 586 | 587 | instance (HasTrie a, Monoid b) => Monoid (a :->: b) where 588 | mempty = trie mempty 589 | #if !MIN_VERSION_base(4,11,0) 590 | mappend = inTrie2 mappend 591 | #else 592 | instance (HasTrie a, Semigroup b) => Semigroup (a :->: b) where 593 | (<>) = inTrie2 (<>) 594 | #endif 595 | 596 | instance HasTrie a => Functor ((:->:) a) where 597 | fmap f = inTrie (fmap f) 598 | 599 | instance HasTrie a => Applicative ((:->:) a) where 600 | pure b = trie (pure b) 601 | (<*>) = inTrie2 (<*>) 602 | 603 | instance HasTrie a => Monad ((:->:) a) where 604 | return a = trie (return a) 605 | u >>= k = trie (untrie u >>= untrie . k) 606 | 607 | -- | Identity trie 608 | idTrie :: HasTrie a => a :->: a 609 | idTrie = trie id 610 | 611 | infixr 9 @.@ 612 | -- | Trie composition 613 | (@.@) :: (HasTrie a, HasTrie b) => 614 | (b :->: c) -> (a :->: b) -> (a :->: c) 615 | (@.@) = inTrie2 (.) 616 | 617 | 618 | -- instance Category (:->:) where 619 | -- id = idTrie 620 | -- (.) = (.:) 621 | 622 | -- instance Arrow (:->:) where 623 | -- arr f = trie (arr f) 624 | -- first = inTrie first 625 | 626 | {- 627 | 628 | Correctness of these instances follows by applying 'untrie' to each side 629 | of each definition and using the property @'untrie' . 'trie' == 'id'@. 630 | 631 | The `Category` and `Arrow` instances don't quite work, however, because of 632 | necessary but disallowed `HasTrie` constraints on the domain type. 633 | 634 | -} 635 | 636 | ---- To go elsewhere 637 | 638 | -- Matt Hellige's notation for @argument f . result g@. 639 | -- 640 | 641 | (~>) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b')) 642 | g ~> f = (f .) . (. g) 643 | 644 | {- 645 | -- Examples 646 | f1,f1' :: Int -> Int 647 | f1 n = n + n 648 | 649 | f1' = memo f1 650 | -} 651 | 652 | -- | just like @void@ 653 | instance HasTrie (V1 x) where 654 | data (V1 x :->: b) = V1Trie 655 | trie _ = V1Trie 656 | untrie V1Trie = \ _ -> error "untrie V1Trie" 657 | -- \case -- needs EmptyCase 658 | enumerate V1Trie = [] 659 | 660 | -- | just like @()@ 661 | instance HasTrie (U1 x) where 662 | newtype (U1 x :->: b) = U1Trie b 663 | trie f = U1Trie (f U1) 664 | untrie (U1Trie b) = \U1 -> b 665 | enumerate (U1Trie b) = [(U1, b)] 666 | 667 | -- | wraps @Either (f x) (g x)@ 668 | instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :+: g) x) where 669 | newtype ((f :+: g) x :->: b) = EitherTrie1 (Either (f x) (g x) :->: b) 670 | trie f = EitherTrie1 (trie (f . liftSum)) 671 | untrie (EitherTrie1 t) = untrie t . dropSum 672 | enumerate (EitherTrie1 t) = enum' liftSum t 673 | 674 | -- | wraps @(f x, g x)@ 675 | instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :*: g) x) where 676 | newtype ((f :*: g) x :->: b) = PairTrie1 ((f x, g x) :->: b) 677 | trie f = PairTrie1 (trie (f . liftProduct)) 678 | untrie (PairTrie1 t) = untrie t . dropProduct 679 | enumerate (PairTrie1 t) = enum' liftProduct t 680 | 681 | -- | wraps @a@ 682 | instance (HasTrie a) => HasTrie (K1 i a x) where 683 | newtype (K1 i a x :->: b) = K1Trie (a :->: b) 684 | trie f = K1Trie (trie (f . K1)) 685 | untrie (K1Trie t) = \(K1 a) -> untrie t a 686 | enumerate (K1Trie t) = enum' K1 t 687 | 688 | -- | wraps @f x@ 689 | instance (HasTrie (f x)) => HasTrie (M1 i t f x) where 690 | newtype (M1 i t f x :->: b) = M1Trie (f x :->: b) 691 | trie f = M1Trie (trie (f . M1)) 692 | untrie (M1Trie t) = \(M1 a) -> untrie t a 693 | enumerate (M1Trie t) = enum' M1 t 694 | 695 | -- | the data type in a __reg__ular form. 696 | -- "unlifted" generic representation. (i.e. is a unary type constructor). 697 | type Reg a = Rep a () 698 | 699 | -- | 'Generic'-friendly default for 'trie' 700 | trieGeneric :: (Generic a, HasTrie (Reg a)) 701 | => ((Reg a :->: b) -> (a :->: b)) 702 | -> (a -> b) 703 | -> (a :->: b) 704 | trieGeneric theConstructor f = theConstructor (trie (f . to)) 705 | {-# INLINEABLE trieGeneric #-} 706 | 707 | -- | 'Generic'-friendly default for 'untrie' 708 | untrieGeneric :: (Generic a, HasTrie (Reg a)) 709 | => ((a :->: b) -> (Reg a :->: b)) 710 | -> (a :->: b) 711 | -> (a -> b) 712 | untrieGeneric theDestructor t = \a -> untrie (theDestructor t) (from a) 713 | {-# INLINEABLE untrieGeneric #-} 714 | 715 | -- | 'Generic'-friendly default for 'enumerate' 716 | enumerateGeneric :: (Generic a, HasTrie (Reg a)) 717 | => ((a :->: b) -> (Reg a :->: b)) 718 | -> (a :->: b) 719 | -> [(a, b)] 720 | enumerateGeneric theDestructor t = enum' to (theDestructor t) 721 | {-# INLINEABLE enumerateGeneric #-} 722 | 723 | dropProduct :: (f :*: g) a -> (f a, g a) 724 | dropProduct (a :*: b) = (a, b) 725 | {-# INLINEABLE dropProduct #-} 726 | 727 | liftProduct :: (f a, g a) -> (f :*: g) a 728 | liftProduct (a, b) = a :*: b 729 | {-# INLINEABLE liftProduct #-} 730 | 731 | dropSum :: (f :+: g) a -> Either (f a) (g a) 732 | dropSum s = case s of 733 | L1 x -> Left x 734 | R1 x -> Right x 735 | {-# INLINEABLE dropSum #-} 736 | 737 | liftSum :: Either (f a) (g a) -> (f :+: g) a 738 | liftSum = either L1 R1 739 | {-# INLINEABLE liftSum #-} 740 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # resolver: lts-9.21 # ghc-8.0.2 2 | # resolver: lts-11.22 # ghc-8.2.2 3 | # resolver: lts-12.14 # ghc-8.4.3 4 | # resolver: lts-12.19 # ghc-8.4.4 5 | # resolver: lts-13.0 # ghc-8.6.3 6 | # resolver: lts-13.13 # ghc-8.6.4 7 | # resolver: lts-14.6 # ghc-8.6.5 8 | resolver: nightly-2020-06-19 # ghc-8.10.1 9 | --------------------------------------------------------------------------------