{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, ScopedTypeVariables, CPP #-}
{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-} 
{-# LANGUAGE DefaultSignatures, FlexibleContexts, LambdaCase #-}
{-# OPTIONS_GHC -Wall -fenable-rewrite-rules #-}

-- ScopedTypeVariables works around a 6.10 bug.  The forall keyword is
-- supposed to be recognized in a RULES pragma.

----------------------------------------------------------------------
-- |
-- Module      :  Data.MemoTrie
-- Copyright   :  (c) Conal Elliott 2008-2016
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Trie-based memoizer
-- 
-- Adapted from sjanssen's paste: <http://hpaste.org/3839 \"a lazy trie\">,
-- which I think is based on Ralf Hinze's paper "Memo Functions,
-- Polytypically!".
-- 
-- You can automatically derive generic instances. for example: 
-- 
-- @
-- {-# LANGUAGE <https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html DeriveGeneric>, TypeOperators, TypeFamilies #-}
-- import Data.MemoTrie
-- import GHC.Generics (Generic) 
-- 
-- data Color = RGB Int Int Int
--            | NamedColor String 
--  deriving ('Generic') 
-- 
-- instance HasTrie Color where
--   newtype (Color :->: b) = ColorTrie { unColorTrie :: 'Reg' Color :->: b } 
--   trie = 'trieGeneric' ColorTrie 
--   untrie = 'untrieGeneric' unColorTrie
--   enumerate = 'enumerateGeneric' unColorTrie
-- @
-- 
-- see @examples/Generic.hs@, which can be run with: 
-- 
-- @
-- cabal configure -fexamples && cabal run generic
-- @ 
-- 
-- 
----------------------------------------------------------------------

module Data.MemoTrie
  ( HasTrie(..), (:->:)(..)
  , domain, idTrie, (@.@)
  -- , trie2, trie3, untrie2, untrie3
  , memo, memo2, memo3, mup
  , inTrie, inTrie2, inTrie3
  -- , untrieBits
  , trieGeneric, untrieGeneric, enumerateGeneric, Reg
  , memoFix
  ) where

-- Export the parts of HasTrie separately in order to get the associated data
-- type constructors, so I can define instances of other classes on them.

import Data.Function (fix)
import Data.Bits
import Data.Word
import Data.Int
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Arrow (first,(&&&))
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Data.Function (on)
import GHC.Generics

import Control.Newtype.Generics

import Data.Void (Void) 
 
-- import Prelude hiding (id,(.))
-- import Control.Category
-- import Control.Arrow

infixr 0 :->:

-- | Mapping from all elements of @a@ to the results of some function
class HasTrie a where
    -- | Representation of trie with domain type @a@
    data (:->:) a :: * -> *
    -- | Create the trie for the entire domain of a function
    trie   :: (a  ->  b) -> (a :->: b)
    -- | Convert a trie to a function, i.e., access a field of the trie
    untrie :: (a :->: b) -> (a  ->  b)
    -- | List the trie elements.  Order of keys (@:: a@) is always the same.
    enumerate :: (a :->: b) -> [(a,b)]

-- | Domain elements of a trie
domain :: HasTrie a => [a]
domain :: [a]
domain = ((a, Any) -> a) -> [(a, Any)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Any) -> a
forall a b. (a, b) -> a
fst ((a :->: Any) -> [(a, Any)]
forall a b. HasTrie a => (a :->: b) -> [(a, b)]
enumerate ((a -> Any) -> a :->: Any
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (Any -> a -> Any
forall a b. a -> b -> a
const Any
forall a. a
oops)))
 where
   oops :: a
oops = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Data.MemoTrie.domain: range element evaluated."

-- Hm: domain :: [Bool] doesn't produce any output.

instance (HasTrie a, Eq b) => Eq (a :->: b) where
  == :: (a :->: b) -> (a :->: b) -> Bool
(==) = [b] -> [b] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([b] -> [b] -> Bool)
-> ((a :->: b) -> [b]) -> (a :->: b) -> (a :->: b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd ([(a, b)] -> [b]) -> ((a :->: b) -> [(a, b)]) -> (a :->: b) -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a :->: b) -> [(a, b)]
forall a b. HasTrie a => (a :->: b) -> [(a, b)]
enumerate)

instance (HasTrie a, Show a, Show b) => Show (a :->: b) where
  show :: (a :->: b) -> [Char]
show a :->: b
t = [Char]
"Trie: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [(a, b)] -> [Char]
forall a. Show a => a -> [Char]
show ((a :->: b) -> [(a, b)]
forall a b. HasTrie a => (a :->: b) -> [(a, b)]
enumerate a :->: b
t)

{-
trie2 :: (HasTrie a, HasTrie b) =>
         (a -> b -> c) -> (a :->: b :->: c)
-- trie2 h = trie $ \ a -> trie $ \ b -> h a b
-- trie2 h = trie $ \ a -> trie (h a)
trie2 h = trie (trie . h)
-- trie2 h = trie (fmap trie h)
-- trie2 = (fmap.fmap) trie trie


trie3 :: (HasTrie a, HasTrie b, HasTrie c) =>
         (a -> b -> c -> d) -> (a :->: b :->: c :->: d)
trie3 h = trie (trie2 . h)

untrie2 :: (HasTrie a, HasTrie b) =>
          (a :->: b :->: c)-> (a -> b -> c)
untrie2 tt = untrie . untrie tt


untrie3 :: (HasTrie a, HasTrie b, HasTrie c) =>
          (a :->: b :->: c :->: d)-> (a -> b -> c -> d)
untrie3 tt = untrie2 . untrie tt
-}


-- {-# RULES "trie/untrie"   forall t. trie (untrie t) = t #-}

--     warning: [-Winline-rule-shadowing] …
--     Rule "trie/untrie" may never fire
--       because rule "Class op untrie" for ‘untrie’ might fire first
--     Probable fix: add phase [n] or [~n] to the competing rule


-- Don't include the dual rule:
--   "untrie/trie"   forall f. untrie (trie f) = f
-- which would defeat memoization.
--
-- TODO: experiment with rule application.  Maybe re-enable "untrie/trie"
-- but fiddle with phases, so it won't defeat 'memo'.

-- | Trie-based function memoizer
memo :: HasTrie t => (t -> a) -> (t -> a)
memo :: (t -> a) -> t -> a
memo = (t :->: a) -> t -> a
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((t :->: a) -> t -> a)
-> ((t -> a) -> t :->: a) -> (t -> a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> a) -> t :->: a
forall a b. HasTrie a => (a -> b) -> a :->: b
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) => (s -> t -> a) -> (s -> t -> a)

-- | Memoize a ternary function on successive arguments.  Take care to
-- exploit any partial evaluation.
memo3 :: (HasTrie r,HasTrie s,HasTrie t) => (r -> s -> t -> a) -> (r -> s -> t -> a)

-- | Lift a memoizer to work with one more argument.
mup :: HasTrie t => (b -> c) -> (t -> b) -> (t -> c)
mup :: (b -> c) -> (t -> b) -> t -> c
mup b -> c
mem t -> b
f = (t -> c) -> t -> c
forall t a. HasTrie t => (t -> a) -> t -> a
memo (b -> c
mem (b -> c) -> (t -> b) -> t -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> b
f)

memo2 :: (s -> t -> a) -> s -> t -> a
memo2 = ((t -> a) -> t -> a) -> (s -> t -> a) -> s -> t -> a
forall t b c. HasTrie t => (b -> c) -> (t -> b) -> t -> c
mup (t -> a) -> t -> a
forall t a. HasTrie t => (t -> a) -> t -> a
memo
memo3 :: (r -> s -> t -> a) -> r -> s -> t -> a
memo3 = ((s -> t -> a) -> s -> t -> a)
-> (r -> s -> t -> a) -> r -> s -> t -> a
forall t b c. HasTrie t => (b -> c) -> (t -> b) -> t -> c
mup (s -> t -> a) -> s -> t -> a
forall s t a.
(HasTrie s, HasTrie t) =>
(s -> t -> a) -> s -> t -> a
memo2

-- | Memoizing recursion. Use like `fix`.
memoFix :: HasTrie a => ((a -> b) -> (a -> b)) -> (a -> b)
memoFix :: ((a -> b) -> a -> b) -> a -> b
memoFix (a -> b) -> a -> b
h = ((a -> b) -> a -> b) -> a -> b
forall a. (a -> a) -> a
fix ((a -> b) -> a -> b
forall t a. HasTrie t => (t -> a) -> t -> a
memo ((a -> b) -> a -> b) -> ((a -> b) -> a -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> a -> b
h)

#if 0
-- Equivalently,

memoFix h = fix (\ f' -> memo (h f'))

memoFix h = f'
  where f' = memo (h f')

memoFix h = f'
 where
   f' = memo f
   f  = h f'
#endif

#if 0
-- Example

fibF :: (Integer -> Integer) -> (Integer -> Integer)
fibF _ 0 = 1
fibF _ 1 = 1
fibF f n = f (n-1) + f (n-2)

fib :: Integer -> Integer
fib = fix fibF

fib' :: Integer -> Integer
fib' = memoFix fibF

-- Try fib 30 vs fib' 30
#endif


-- | Apply a unary function inside of a trie
inTrie :: (HasTrie a, HasTrie c) =>
          ((a  ->  b) -> (c  ->  d))
       -> ((a :->: b) -> (c :->: d))
inTrie :: ((a -> b) -> c -> d) -> (a :->: b) -> c :->: d
inTrie = (a :->: b) -> a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((a :->: b) -> a -> b)
-> ((c -> d) -> c :->: d)
-> ((a -> b) -> c -> d)
-> (a :->: b)
-> c :->: d
forall a' a b b'. (a' -> a) -> (b -> b') -> (a -> b) -> a' -> b'
~> (c -> d) -> c :->: d
forall a b. HasTrie a => (a -> b) -> a :->: b
trie

-- | Apply a binary function inside of a trie
inTrie2 :: (HasTrie a, HasTrie c, HasTrie e) =>
           ((a  ->  b) -> (c  ->  d) -> (e  ->  f))
        -> ((a :->: b) -> (c :->: d) -> (e :->: f))
inTrie2 :: ((a -> b) -> (c -> d) -> e -> f)
-> (a :->: b) -> (c :->: d) -> e :->: f
inTrie2 = (a :->: b) -> a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((a :->: b) -> a -> b)
-> (((c -> d) -> e -> f) -> (c :->: d) -> e :->: f)
-> ((a -> b) -> (c -> d) -> e -> f)
-> (a :->: b)
-> (c :->: d)
-> e :->: f
forall a' a b b'. (a' -> a) -> (b -> b') -> (a -> b) -> a' -> b'
~> ((c -> d) -> e -> f) -> (c :->: d) -> e :->: f
forall a c b d.
(HasTrie a, HasTrie c) =>
((a -> b) -> c -> d) -> (a :->: b) -> c :->: d
inTrie

-- | Apply a ternary function inside of a trie
inTrie3 :: (HasTrie a, HasTrie c, HasTrie e, HasTrie g) =>
           ((a  ->  b) -> (c  ->  d) -> (e  ->  f) -> (g  ->  h))
        -> ((a :->: b) -> (c :->: d) -> (e :->: f) -> (g :->: h))
inTrie3 :: ((a -> b) -> (c -> d) -> (e -> f) -> g -> h)
-> (a :->: b) -> (c :->: d) -> (e :->: f) -> g :->: h
inTrie3 = (a :->: b) -> a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((a :->: b) -> a -> b)
-> (((c -> d) -> (e -> f) -> g -> h)
    -> (c :->: d) -> (e :->: f) -> g :->: h)
-> ((a -> b) -> (c -> d) -> (e -> f) -> g -> h)
-> (a :->: b)
-> (c :->: d)
-> (e :->: f)
-> g :->: h
forall a' a b b'. (a' -> a) -> (b -> b') -> (a -> b) -> a' -> b'
~> ((c -> d) -> (e -> f) -> g -> h)
-> (c :->: d) -> (e :->: f) -> g :->: h
forall a c e b d f.
(HasTrie a, HasTrie c, HasTrie e) =>
((a -> b) -> (c -> d) -> e -> f)
-> (a :->: b) -> (c :->: d) -> e :->: f
inTrie2


---- Instances

instance HasTrie Void where
  -- As suggested by Audun Skaugen
  data Void :->: a = VoidTrie
  trie :: (Void -> b) -> Void :->: b
trie Void -> b
_ = Void :->: b
forall a. Void :->: a
VoidTrie
  untrie :: (Void :->: b) -> Void -> b
untrie Void :->: b
VoidTrie = \ Void
_ -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"untrie VoidTrie"
                    -- \case  -- needs EmptyCase
  enumerate :: (Void :->: b) -> [(Void, b)]
enumerate Void :->: b
VoidTrie = []

instance Newtype (Void :->: a) where
  type O (Void :->: a) = ()
  pack :: O (Void :->: a) -> Void :->: a
pack () = Void :->: a
forall a. Void :->: a
VoidTrie
  unpack :: (Void :->: a) -> O (Void :->: a)
unpack Void :->: a
VoidTrie = ()

instance HasTrie () where
  newtype () :->: a = UnitTrie a
  trie :: (() -> b) -> () :->: b
trie () -> b
f = b -> () :->: b
forall a. a -> () :->: a
UnitTrie (() -> b
f ())
  untrie :: (() :->: b) -> () -> b
untrie (UnitTrie a) = \ () -> b
a
  enumerate :: (() :->: b) -> [((), b)]
enumerate (UnitTrie a) = [((),b
a)]

instance Newtype (() :->: a) where
  type O (() :->: a) = a
  pack :: O (() :->: a) -> () :->: a
pack O (() :->: a)
a = a -> () :->: a
forall a. a -> () :->: a
UnitTrie a
O (() :->: a)
a
  unpack :: (() :->: a) -> O (() :->: a)
unpack (UnitTrie a) = a
O (() :->: a)
a

-- Proofs of inverse properties:

{-
    untrie (trie f)
      == { trie def }
    untrie (UnitTrie (f ()))
      == { untrie def }
    \ () -> (f ())
      == { const-unit }
    f   

    trie (untrie (UnitTrie a))
      == { untrie def }
    trie (\ () -> a)
      == { trie def }
    UnitTrie ((\ () -> a) ())
      == { beta-reduction }
    UnitTrie a

Oops -- the last step of the first direction is bogus when f is non-strict.
Can be fixed by using @const a@ in place of @\ () -> a@, but I can't do
the same for other types, like integers or sums.

All of these proofs have this same bug, unless we restrict ourselves to
memoizing hyper-strict functions.

-}


instance HasTrie Bool where
  data Bool :->: x = BoolTrie x x
  trie :: (Bool -> b) -> Bool :->: b
trie Bool -> b
f = b -> b -> Bool :->: b
forall x. x -> x -> Bool :->: x
BoolTrie (Bool -> b
f Bool
False) (Bool -> b
f Bool
True)
  untrie :: (Bool :->: b) -> Bool -> b
untrie (BoolTrie f t) = b -> b -> Bool -> b
forall x. x -> x -> Bool -> x
if' b
f b
t
  enumerate :: (Bool :->: b) -> [(Bool, b)]
enumerate (BoolTrie f t) = [(Bool
False,b
f),(Bool
True,b
t)]

instance Newtype (Bool :->: a) where
  type O (Bool :->: a) = (a,a)
  pack :: O (Bool :->: a) -> Bool :->: a
pack (a,a') = a -> a -> Bool :->: a
forall x. x -> x -> Bool :->: x
BoolTrie a
a a
a'
  unpack :: (Bool :->: a) -> O (Bool :->: a)
unpack (BoolTrie a a') = (a
a,a
a')

-- | Conditional with boolean last.
-- Spec: @if' (f False) (f True) == f@
if' :: x -> x -> Bool -> x
if' :: x -> x -> Bool -> x
if' x
t x
_ Bool
False = x
t
if' x
_ x
e Bool
True  = x
e

{-
    untrie (trie f)
      == { trie def }
    untrie (BoolTrie (f False) (f True))
      == { untrie def }
    if' (f False) (f True)
      == { if' spec }
    f

    trie (untrie (BoolTrie f t))
      == { untrie def }
    trie (if' f t)
      == { trie def }
    BoolTrie (if' f t False) (if' f t True)
      == { if' spec }
    BoolTrie f t
-}

instance HasTrie a => HasTrie (Maybe a) where
  data (:->:) (Maybe a) b = MaybeTrie b (a :->: b)
  trie :: (Maybe a -> b) -> Maybe a :->: b
trie Maybe a -> b
f = b -> (a :->: b) -> Maybe a :->: b
forall a b. b -> (a :->: b) -> Maybe a :->: b
MaybeTrie (Maybe a -> b
f Maybe a
forall a. Maybe a
Nothing) ((a -> b) -> a :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (Maybe a -> b
f (Maybe a -> b) -> (a -> Maybe a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just))
  untrie :: (Maybe a :->: b) -> Maybe a -> b
untrie (MaybeTrie nothing_val a_trie) = b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
nothing_val ((a :->: b) -> a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie a :->: b
a_trie)
  enumerate :: (Maybe a :->: b) -> [(Maybe a, b)]
enumerate (MaybeTrie nothing_val a_trie) = (Maybe a
forall a. Maybe a
Nothing, b
nothing_val) (Maybe a, b) -> [(Maybe a, b)] -> [(Maybe a, b)]
forall a. a -> [a] -> [a]
: (a -> Maybe a) -> (a :->: b) -> [(Maybe a, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' a -> Maybe a
forall a. a -> Maybe a
Just a :->: b
a_trie

instance Newtype (Maybe a :->: x) where
  type O (Maybe a :->: x) = (x, a :->: x)
  pack :: O (Maybe a :->: x) -> Maybe a :->: x
pack (a,f) = x -> (a :->: x) -> Maybe a :->: x
forall a b. b -> (a :->: b) -> Maybe a :->: b
MaybeTrie x
a a :->: x
f
  unpack :: (Maybe a :->: x) -> O (Maybe a :->: x)
unpack (MaybeTrie a f) = (x
a,a :->: x
f)

instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
  data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x)
  trie :: (Either a b -> b) -> Either a b :->: b
trie Either a b -> b
f = (a :->: b) -> (b :->: b) -> Either a b :->: b
forall a b x. (a :->: x) -> (b :->: x) -> Either a b :->: x
EitherTrie ((a -> b) -> a :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (Either a b -> b
f (Either a b -> b) -> (a -> Either a b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left)) ((b -> b) -> b :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (Either a b -> b
f (Either a b -> b) -> (b -> Either a b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right))
  untrie :: (Either a b :->: b) -> Either a b -> b
untrie (EitherTrie s t) = (a -> b) -> (b -> b) -> Either a b -> b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((a :->: b) -> a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie a :->: b
s) ((b :->: b) -> b -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie b :->: b
t)
  enumerate :: (Either a b :->: b) -> [(Either a b, b)]
enumerate (EitherTrie s t) = (a -> Either a b) -> (a :->: b) -> [(Either a b, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' a -> Either a b
forall a b. a -> Either a b
Left a :->: b
s [(Either a b, b)] -> [(Either a b, b)] -> [(Either a b, b)]
forall a. [a] -> [a] -> [a]
`weave` (b -> Either a b) -> (b :->: b) -> [(Either a b, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' b -> Either a b
forall a b. b -> Either a b
Right b :->: b
t

instance Newtype (Either a b :->: x) where
  type O (Either a b :->: x) = (a :->: x, b :->: x)
  pack :: O (Either a b :->: x) -> Either a b :->: x
pack (f,g) = (a :->: x) -> (b :->: x) -> Either a b :->: x
forall a b x. (a :->: x) -> (b :->: x) -> Either a b :->: x
EitherTrie a :->: x
f b :->: x
g
  unpack :: (Either a b :->: x) -> O (Either a b :->: x)
unpack (EitherTrie f g) = (a :->: x
f,b :->: x
g)

enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)]
enum' :: (a -> a') -> (a :->: b) -> [(a', b)]
enum' a -> a'
f = (((a, b) -> (a', b)) -> [(a, b)] -> [(a', b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap(((a, b) -> (a', b)) -> [(a, b)] -> [(a', b)])
-> ((a -> a') -> (a, b) -> (a', b))
-> (a -> a')
-> [(a, b)]
-> [(a', b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> a') -> (a, b) -> (a', b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first) a -> a'
f ([(a, b)] -> [(a', b)])
-> ((a :->: b) -> [(a, b)]) -> (a :->: b) -> [(a', b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a :->: b) -> [(a, b)]
forall a b. HasTrie a => (a :->: b) -> [(a, b)]
enumerate

weave :: [a] -> [a] -> [a]
[] weave :: [a] -> [a] -> [a]
`weave` [a]
as = [a]
as
[a]
as `weave` [] = [a]
as
(a
a:[a]
as) `weave` [a]
bs = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ([a]
bs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
`weave` [a]
as)

{-
    untrie (trie f)
       == { trie def }
    untrie (EitherTrie (trie (f . Left)) (trie (f . Right)))
       == { untrie def }
    either (untrie (trie (f . Left))) (untrie (trie (f . Right)))
       == { untrie . trie }
    either (f . Left) (f . Right)
       == { either }
    f

    trie (untrie (EitherTrie s t))
       == { untrie def }
    trie (either (untrie s) (untrie t))
       == { trie def }
    EitherTrie (trie (either (untrie s) (untrie t) . Left))
               (trie (either (untrie s) (untrie t) . Right))
       == { either }
    EitherTrie (trie (untrie s)) (trie (untrie t))
       == { trie . untrie }
    EitherTrie s t
-}


instance (HasTrie a, HasTrie b) => HasTrie (a,b) where
  newtype (a,b) :->: x = PairTrie (a :->: (b :->: x))
  trie :: ((a, b) -> b) -> (a, b) :->: b
trie (a, b) -> b
f = (a :->: (b :->: b)) -> (a, b) :->: b
forall a b x. (a :->: (b :->: x)) -> (a, b) :->: x
PairTrie ((a -> b :->: b) -> a :->: (b :->: b)
forall a b. HasTrie a => (a -> b) -> a :->: b
trie ((b -> b) -> b :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie ((b -> b) -> b :->: b) -> (a -> b -> b) -> a -> b :->: b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> b) -> a -> b -> b
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, b) -> b
f))
  untrie :: ((a, b) :->: b) -> (a, b) -> b
untrie (PairTrie t) = (a -> b -> b) -> (a, b) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((b :->: b) -> b -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((b :->: b) -> b -> b) -> (a -> b :->: b) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (a :->: (b :->: b)) -> a -> b :->: b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie a :->: (b :->: b)
t)
  enumerate :: ((a, b) :->: b) -> [((a, b), b)]
enumerate (PairTrie tt) =
    [ ((a
a,b
b),b
x) | (a
a,b :->: b
t) <- (a :->: (b :->: b)) -> [(a, b :->: b)]
forall a b. HasTrie a => (a :->: b) -> [(a, b)]
enumerate a :->: (b :->: b)
tt , (b
b,b
x) <- (b :->: b) -> [(b, b)]
forall a b. HasTrie a => (a :->: b) -> [(a, b)]
enumerate b :->: b
t ]

instance Newtype ((a,b) :->: x) where
  type O ((a,b) :->: x) = a :->: b :->: x
  pack :: O ((a, b) :->: x) -> (a, b) :->: x
pack O ((a, b) :->: x)
abx = (a :->: (b :->: x)) -> (a, b) :->: x
forall a b x. (a :->: (b :->: x)) -> (a, b) :->: x
PairTrie O ((a, b) :->: x)
a :->: (b :->: x)
abx
  unpack :: ((a, b) :->: x) -> O ((a, b) :->: x)
unpack (PairTrie abx) = O ((a, b) :->: x)
a :->: (b :->: x)
abx

{-
    untrie (trie f)
      == { trie def }
    untrie (PairTrie (trie (trie . curry f)))
      == { untrie def }
    uncurry (untrie . untrie (trie (trie . curry f)))
      == { untrie . trie }
    uncurry (untrie . trie . curry f)
      == { untrie . untrie }
    uncurry (curry f)
      == { uncurry . curry }
    f

    trie (untrie (PairTrie t))
      == { untrie def }
    trie (uncurry (untrie .  untrie t))
      == { trie def }
    PairTrie (trie (trie . curry (uncurry (untrie .  untrie t))))
      == { curry . uncurry }
    PairTrie (trie (trie . untrie .  untrie t))
      == { trie . untrie }
    PairTrie (trie (untrie t))
      == { trie . untrie }
    PairTrie t
-}

instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where
  newtype (a,b,c) :->: x = TripleTrie (((a,b),c) :->: x)
  trie :: ((a, b, c) -> b) -> (a, b, c) :->: b
trie (a, b, c) -> b
f = (((a, b), c) :->: b) -> (a, b, c) :->: b
forall a b c x. (((a, b), c) :->: x) -> (a, b, c) :->: x
TripleTrie ((((a, b), c) -> b) -> ((a, b), c) :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie ((a, b, c) -> b
f ((a, b, c) -> b) -> (((a, b), c) -> (a, b, c)) -> ((a, b), c) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b), c) -> (a, b, c)
forall a b c. ((a, b), c) -> (a, b, c)
trip))
  untrie :: ((a, b, c) :->: b) -> (a, b, c) -> b
untrie (TripleTrie t) = (((a, b), c) :->: b) -> ((a, b), c) -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((a, b), c) :->: b
t (((a, b), c) -> b) -> ((a, b, c) -> ((a, b), c)) -> (a, b, c) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c) -> ((a, b), c)
forall a b c. (a, b, c) -> ((a, b), c)
detrip
  enumerate :: ((a, b, c) :->: b) -> [((a, b, c), b)]
enumerate (TripleTrie t) = (((a, b), c) -> (a, b, c))
-> (((a, b), c) :->: b) -> [((a, b, c), b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' ((a, b), c) -> (a, b, c)
forall a b c. ((a, b), c) -> (a, b, c)
trip ((a, b), c) :->: b
t

trip :: ((a,b),c) -> (a,b,c)
trip :: ((a, b), c) -> (a, b, c)
trip ((a
a,b
b),c
c) = (a
a,b
b,c
c)

detrip :: (a,b,c) -> ((a,b),c)
detrip :: (a, b, c) -> ((a, b), c)
detrip (a
a,b
b,c
c) = ((a
a,b
b),c
c)


instance HasTrie x => HasTrie [x] where
  newtype [x] :->: a = ListTrie (Either () (x,[x]) :->: a)
  trie :: ([x] -> b) -> [x] :->: b
trie [x] -> b
f = (Either () (x, [x]) :->: b) -> [x] :->: b
forall x a. (Either () (x, [x]) :->: a) -> [x] :->: a
ListTrie ((Either () (x, [x]) -> b) -> Either () (x, [x]) :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie ([x] -> b
f ([x] -> b)
-> (Either () (x, [x]) -> [x]) -> Either () (x, [x]) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either () (x, [x]) -> [x]
forall x. Either () (x, [x]) -> [x]
list))
  untrie :: ([x] :->: b) -> [x] -> b
untrie (ListTrie t) = (Either () (x, [x]) :->: b) -> Either () (x, [x]) -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie Either () (x, [x]) :->: b
t (Either () (x, [x]) -> b)
-> ([x] -> Either () (x, [x])) -> [x] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [x] -> Either () (x, [x])
forall x. [x] -> Either () (x, [x])
delist
  enumerate :: ([x] :->: b) -> [([x], b)]
enumerate (ListTrie t) = (Either () (x, [x]) -> [x])
-> (Either () (x, [x]) :->: b) -> [([x], b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' Either () (x, [x]) -> [x]
forall x. Either () (x, [x]) -> [x]
list Either () (x, [x]) :->: b
t

list :: Either () (x,[x]) -> [x]
list :: Either () (x, [x]) -> [x]
list = (() -> [x]) -> ((x, [x]) -> [x]) -> Either () (x, [x]) -> [x]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([x] -> () -> [x]
forall a b. a -> b -> a
const []) ((x -> [x] -> [x]) -> (x, [x]) -> [x]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:))

delist :: [x] -> Either () (x,[x])
delist :: [x] -> Either () (x, [x])
delist []     = () -> Either () (x, [x])
forall a b. a -> Either a b
Left ()
delist (x
x:[x]
xs) = (x, [x]) -> Either () (x, [x])
forall a b. b -> Either a b
Right (x
x,[x]
xs)

#define WordInstance(Type,TrieType)\
instance HasTrie Type where \
  newtype Type :->: a = TrieType ([Bool] :->: a);\
  trie f = TrieType (trie (f . unbits));\
  untrie (TrieType t) = untrie t . bits;\
  enumerate (TrieType t) = enum' unbits t

WordInstance(Word,WordTrie)
WordInstance(Word8,Word8Trie)
WordInstance(Word16,Word16Trie)
WordInstance(Word32,Word32Trie)
WordInstance(Word64,Word64Trie)

-- instance HasTrie Word where
--   newtype Word :->: a = WordTrie ([Bool] :->: a)
--   trie f = WordTrie (trie (f . unbits))
--   untrie (WordTrie t) = untrie t . bits
--   enumerate (WordTrie t) = enum' unbits t


-- | Extract bits in little-endian order
bits :: (Num t, Bits t) => t -> [Bool]
bits :: t -> [Bool]
bits t
0 = []
bits t
x = t -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit t
x Int
0 Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: t -> [Bool]
forall t. (Num t, Bits t) => t -> [Bool]
bits (t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftR t
x Int
1)

-- | Convert boolean to 0 (False) or 1 (True)
unbit :: Num t => Bool -> t
unbit :: Bool -> t
unbit Bool
False = t
0
unbit Bool
True  = t
1

-- | Bit list to value
unbits :: (Num t, Bits t) => [Bool] -> t
unbits :: [Bool] -> t
unbits [] = t
0
unbits (Bool
x:[Bool]
xs) = Bool -> t
forall t. Num t => Bool -> t
unbit Bool
x t -> t -> t
forall a. Bits a => a -> a -> a
.|. t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftL ([Bool] -> t
forall t. (Num t, Bits t) => [Bool] -> t
unbits [Bool]
xs) Int
1

instance HasTrie Char where
  newtype Char :->: a = CharTrie (Int :->: a)
  untrie :: (Char :->: b) -> Char -> b
untrie (CharTrie t) Char
n = (Int :->: b) -> Int -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie Int :->: b
t (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
n)
  trie :: (Char -> b) -> Char :->: b
trie Char -> b
f = (Int :->: b) -> Char :->: b
forall a. (Int :->: a) -> Char :->: a
CharTrie ((Int -> b) -> Int :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (Char -> b
f (Char -> b) -> (Int -> Char) -> Int -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
forall a. Enum a => Int -> a
toEnum))
  enumerate :: (Char :->: b) -> [(Char, b)]
enumerate (CharTrie t) = (Int -> Char) -> (Int :->: b) -> [(Char, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' Int -> Char
forall a. Enum a => Int -> a
toEnum Int :->: b
t

-- Although Int is a Bits instance, we can't use bits directly for
-- memoizing, because the "bits" function gives an infinite result, since
-- shiftR (-1) 1 == -1.  Instead, convert between Int and Word, and use
-- a Word trie.  Any Integral type can be handled similarly.

#define IntInstance(IntType,WordType,TrieType) \
instance HasTrie IntType where \
  newtype IntType :->: a = TrieType (WordType :->: a); \
  untrie (TrieType t) n = untrie t (fromIntegral n); \
  trie f = TrieType (trie (f . fromIntegral)); \
  enumerate (TrieType t) = enum' fromIntegral t

IntInstance(Int,Word,IntTrie)
IntInstance(Int8,Word8,Int8Trie)
IntInstance(Int16,Word16,Int16Trie)
IntInstance(Int32,Word32,Int32Trie)
IntInstance(Int64,Word64,Int64Trie)

-- For unbounded integers, we don't have a corresponding Word type, so
-- extract the sign bit.

instance HasTrie Integer where
  newtype Integer :->: a = IntegerTrie ((Bool,[Bool]) :->: a)
  trie :: (Integer -> b) -> Integer :->: b
trie Integer -> b
f = ((Bool, [Bool]) :->: b) -> Integer :->: b
forall a. ((Bool, [Bool]) :->: a) -> Integer :->: a
IntegerTrie (((Bool, [Bool]) -> b) -> (Bool, [Bool]) :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (Integer -> b
f (Integer -> b)
-> ((Bool, [Bool]) -> Integer) -> (Bool, [Bool]) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, [Bool]) -> Integer
forall n. (Num n, Bits n) => (Bool, [Bool]) -> n
unbitsZ))
  untrie :: (Integer :->: b) -> Integer -> b
untrie (IntegerTrie t) = ((Bool, [Bool]) :->: b) -> (Bool, [Bool]) -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie (Bool, [Bool]) :->: b
t ((Bool, [Bool]) -> b)
-> (Integer -> (Bool, [Bool])) -> Integer -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> (Bool, [Bool])
forall n. (Num n, Ord n, Bits n) => n -> (Bool, [Bool])
bitsZ
  enumerate :: (Integer :->: b) -> [(Integer, b)]
enumerate (IntegerTrie t) = ((Bool, [Bool]) -> Integer)
-> ((Bool, [Bool]) :->: b) -> [(Integer, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' (Bool, [Bool]) -> Integer
forall n. (Num n, Bits n) => (Bool, [Bool]) -> n
unbitsZ (Bool, [Bool]) :->: b
t


unbitsZ :: (Num n, Bits n) => (Bool,[Bool]) -> n
unbitsZ :: (Bool, [Bool]) -> n
unbitsZ (Bool
positive,[Bool]
bs) = n -> n
sig ([Bool] -> n
forall t. (Num t, Bits t) => [Bool] -> t
unbits [Bool]
bs)
 where
   sig :: n -> n
sig | Bool
positive  = n -> n
forall a. a -> a
id
       | Bool
otherwise = n -> n
forall a. Num a => a -> a
negate

bitsZ :: (Num n, Ord n, Bits n) => n -> (Bool,[Bool])
bitsZ :: n -> (Bool, [Bool])
bitsZ = (n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0) (n -> Bool) -> (n -> [Bool]) -> n -> (Bool, [Bool])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (n -> [Bool]
forall t. (Num t, Bits t) => t -> [Bool]
bits (n -> [Bool]) -> (n -> n) -> n -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n
forall a. Num a => a -> a
abs)

-- TODO: make these definitions more systematic.


---- Instances

{-

The \"semantic function\" 'untrie' is a morphism over 'Monoid', 'Functor',
'Applicative', 'Monad', 'Category', and 'Arrow', i.e.,

  untrie mempty          == mempty
  untrie (s `mappend` t) == untrie s `mappend` untrie t

  untrie (fmap f t)      == fmap f (untrie t)

  untrie (pure a)        == pure a
  untrie (tf <*> tx)     == untrie tf <*> untrie tx

  untrie (return a)      == return a
  untrie (u >>= k)       == untrie u >>= untrie . k

  untrie id              == id
  untrie (s . t)         == untrie s . untrie t

  untrie (arr f)         == arr f
  untrie (first t)       == first (untrie t)

These morphism properties imply that all of the expected laws hold,
assuming that we interpret equality semantically (or observationally).
For instance,

  untrie (mempty `mappend` a)
    == untrie mempty `mappend` untrie a
    == mempty `mappend` untrie a
    == untrie a

  untrie (fmap f (fmap g a))
    == fmap f (untrie (fmap g a))
    == fmap f (fmap g (untrie a))
    == fmap (f.g) (untrie a)
    == untrie (fmap (f.g) a)

The implementation instances then follow from applying 'trie' to both
sides of each of these morphism laws.

-}

{-
instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
  mempty  = trie mempty
  s `mappend` t = trie (untrie s `mappend` untrie t)

instance HasTrie a => Functor ((:->:) a) where
  fmap f t      = trie (fmap f (untrie t))

instance HasTrie a => Applicative ((:->:) a) where
  pure b        = trie (pure b)
  tf <*> tx     = trie (untrie tf <*> untrie tx)

instance HasTrie a => Monad ((:->:) a) where
  return a      = trie (return a)
  u >>= k       = trie (untrie u >>= untrie . k)

-- instance Category (:->:) where
--   id            = trie id
--   s . t         = trie (untrie s . untrie t)

-- instance Arrow (:->:) where
--   arr f         = trie (arr f)
--   first t       = trie (first (untrie t))
-}

-- Simplify, using inTrie, inTrie2

instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
  mempty :: a :->: b
mempty  = (a -> b) -> a :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie a -> b
forall a. Monoid a => a
mempty
#if !MIN_VERSION_base(4,11,0)
  mappend = inTrie2 mappend
#else
instance (HasTrie a, Semigroup b) => Semigroup (a :->: b) where
  <> :: (a :->: b) -> (a :->: b) -> a :->: b
(<>)    = ((a -> b) -> (a -> b) -> a -> b)
-> (a :->: b) -> (a :->: b) -> a :->: b
forall a c e b d f.
(HasTrie a, HasTrie c, HasTrie e) =>
((a -> b) -> (c -> d) -> e -> f)
-> (a :->: b) -> (c :->: d) -> e :->: f
inTrie2 (a -> b) -> (a -> b) -> a -> b
forall a. Semigroup a => a -> a -> a
(<>)
#endif

instance HasTrie a => Functor ((:->:) a) where
  fmap :: (a -> b) -> (a :->: a) -> a :->: b
fmap a -> b
f = ((a -> a) -> a -> b) -> (a :->: a) -> a :->: b
forall a c b d.
(HasTrie a, HasTrie c) =>
((a -> b) -> c -> d) -> (a :->: b) -> c :->: d
inTrie ((a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)

instance HasTrie a => Applicative ((:->:) a) where
  pure :: a -> a :->: a
pure a
b = (a -> a) -> a :->: a
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (a -> a -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b)
  <*> :: (a :->: (a -> b)) -> (a :->: a) -> a :->: b
(<*>)  = ((a -> a -> b) -> (a -> a) -> a -> b)
-> (a :->: (a -> b)) -> (a :->: a) -> a :->: b
forall a c e b d f.
(HasTrie a, HasTrie c, HasTrie e) =>
((a -> b) -> (c -> d) -> e -> f)
-> (a :->: b) -> (c :->: d) -> e :->: f
inTrie2 (a -> a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

instance HasTrie a => Monad ((:->:) a) where
  return :: a -> a :->: a
return a
a = (a -> a) -> a :->: a
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (a -> a -> a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)
  a :->: a
u >>= :: (a :->: a) -> (a -> a :->: b) -> a :->: b
>>= a -> a :->: b
k  = (a -> b) -> a :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie ((a :->: a) -> a -> a
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie a :->: a
u (a -> a) -> (a -> a -> b) -> a -> b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a :->: b) -> a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((a :->: b) -> a -> b) -> (a -> a :->: b) -> a -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a :->: b
k)

-- | Identity trie
idTrie :: HasTrie a => a :->: a
idTrie :: a :->: a
idTrie = (a -> a) -> a :->: a
forall a b. HasTrie a => (a -> b) -> a :->: b
trie a -> a
forall a. a -> a
id

infixr 9 @.@
-- | Trie composition
(@.@) :: (HasTrie a, HasTrie b) =>
         (b :->: c) -> (a :->: b) -> (a :->: c)
@.@ :: (b :->: c) -> (a :->: b) -> a :->: c
(@.@) = ((b -> c) -> (a -> b) -> a -> c)
-> (b :->: c) -> (a :->: b) -> a :->: c
forall a c e b d f.
(HasTrie a, HasTrie c, HasTrie e) =>
((a -> b) -> (c -> d) -> e -> f)
-> (a :->: b) -> (c :->: d) -> e :->: f
inTrie2 (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)


-- instance Category (:->:) where
--   id  = idTrie
--   (.) = (.:)

-- instance Arrow (:->:) where
--   arr f = trie (arr f)
--   first = inTrie first

{-

Correctness of these instances follows by applying 'untrie' to each side
of each definition and using the property @'untrie' . 'trie' == 'id'@.

The `Category` and `Arrow` instances don't quite work, however, because of
necessary but disallowed `HasTrie` constraints on the domain type.

-}

---- To go elsewhere

-- Matt Hellige's notation for @argument f . result g@.
-- <http://matt.immute.net/content/pointless-fun>

(~>) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b'))
a' -> a
g ~> :: (a' -> a) -> (b -> b') -> (a -> b) -> a' -> b'
~> b -> b'
f = (b -> b'
f (b -> b') -> (a' -> b) -> a' -> b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a' -> b) -> a' -> b')
-> ((a -> b) -> a' -> b) -> (a -> b) -> a' -> b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> b) -> (a' -> a) -> a' -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
g)

{-
-- Examples
f1,f1' :: Int -> Int
f1 n = n + n

f1' = memo f1
-}

-- | just like @void@ 
instance HasTrie (V1 x) where
  data (V1 x :->: b) = V1Trie 
  trie :: (V1 x -> b) -> V1 x :->: b
trie V1 x -> b
_ = V1 x :->: b
forall x b. V1 x :->: b
V1Trie 
  untrie :: (V1 x :->: b) -> V1 x -> b
untrie V1 x :->: b
V1Trie = \ V1 x
_ -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"untrie V1Trie"
                  -- \case  -- needs EmptyCase
  enumerate :: (V1 x :->: b) -> [(V1 x, b)]
enumerate V1 x :->: b
V1Trie = [] 

-- | just like @()@ 
instance HasTrie (U1 x) where
  data (U1 x :->: b) = U1Trie b 
  trie :: (U1 x -> b) -> U1 x :->: b
trie U1 x -> b
f = b -> U1 x :->: b
forall x b. b -> U1 x :->: b
U1Trie (U1 x -> b
f U1 x
forall k (p :: k). U1 p
U1)
  untrie :: (U1 x :->: b) -> U1 x -> b
untrie (U1Trie b) = \U1 x
U1 -> b
b
  enumerate :: (U1 x :->: b) -> [(U1 x, b)]
enumerate (U1Trie b) = [(U1 x
forall k (p :: k). U1 p
U1, b
b)] 

-- | wraps @Either (f x) (g x)@ 
instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :+: g) x) where
  newtype ((f :+: g) x :->: b) = EitherTrie1 (Either (f x) (g x) :->: b)
  trie :: ((:+:) f g x -> b) -> (:+:) f g x :->: b
trie (:+:) f g x -> b
f = (Either (f x) (g x) :->: b) -> (:+:) f g x :->: b
forall (f :: * -> *) (g :: * -> *) x b.
(Either (f x) (g x) :->: b) -> (:+:) f g x :->: b
EitherTrie1 ((Either (f x) (g x) -> b) -> Either (f x) (g x) :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie ((:+:) f g x -> b
f ((:+:) f g x -> b)
-> (Either (f x) (g x) -> (:+:) f g x) -> Either (f x) (g x) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (f x) (g x) -> (:+:) f g x
forall (f :: * -> *) a (g :: * -> *).
Either (f a) (g a) -> (:+:) f g a
liftSum))
  untrie :: ((:+:) f g x :->: b) -> (:+:) f g x -> b
untrie (EitherTrie1 t) = ((Either (f x) (g x) :->: b) -> Either (f x) (g x) -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie Either (f x) (g x) :->: b
t) (Either (f x) (g x) -> b)
-> ((:+:) f g x -> Either (f x) (g x)) -> (:+:) f g x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:+:) f g x -> Either (f x) (g x)
forall (f :: * -> *) (g :: * -> *) a.
(:+:) f g a -> Either (f a) (g a)
dropSum
  enumerate :: ((:+:) f g x :->: b) -> [((:+:) f g x, b)]
enumerate (EitherTrie1 t) = (Either (f x) (g x) -> (:+:) f g x)
-> (Either (f x) (g x) :->: b) -> [((:+:) f g x, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' Either (f x) (g x) -> (:+:) f g x
forall (f :: * -> *) a (g :: * -> *).
Either (f a) (g a) -> (:+:) f g a
liftSum Either (f x) (g x) :->: b
t

-- | wraps @(f x, g x)@ 
instance (HasTrie (f x), HasTrie (g x)) => HasTrie ((f :*: g) x) where
  newtype ((f :*: g) x :->: b) = PairTrie1 ((f x, g x) :->: b)
  trie :: ((:*:) f g x -> b) -> (:*:) f g x :->: b
trie (:*:) f g x -> b
f = ((f x, g x) :->: b) -> (:*:) f g x :->: b
forall (f :: * -> *) (g :: * -> *) x b.
((f x, g x) :->: b) -> (:*:) f g x :->: b
PairTrie1 (((f x, g x) -> b) -> (f x, g x) :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie ((:*:) f g x -> b
f ((:*:) f g x -> b)
-> ((f x, g x) -> (:*:) f g x) -> (f x, g x) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f x, g x) -> (:*:) f g x
forall (f :: * -> *) a (g :: * -> *). (f a, g a) -> (:*:) f g a
liftProduct))
  untrie :: ((:*:) f g x :->: b) -> (:*:) f g x -> b
untrie (PairTrie1 t) = (((f x, g x) :->: b) -> (f x, g x) -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie (f x, g x) :->: b
t) ((f x, g x) -> b)
-> ((:*:) f g x -> (f x, g x)) -> (:*:) f g x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:*:) f g x -> (f x, g x)
forall (f :: * -> *) (g :: * -> *) a. (:*:) f g a -> (f a, g a)
dropProduct 
  enumerate :: ((:*:) f g x :->: b) -> [((:*:) f g x, b)]
enumerate (PairTrie1 t) = ((f x, g x) -> (:*:) f g x)
-> ((f x, g x) :->: b) -> [((:*:) f g x, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' (f x, g x) -> (:*:) f g x
forall (f :: * -> *) a (g :: * -> *). (f a, g a) -> (:*:) f g a
liftProduct (f x, g x) :->: b
t

-- | wraps @a@ 
instance (HasTrie a) => HasTrie (K1 i a x) where
  data (K1 i a x :->: b) = K1Trie (a :->: b) 
  trie :: (K1 i a x -> b) -> K1 i a x :->: b
trie K1 i a x -> b
f = (a :->: b) -> K1 i a x :->: b
forall i a x b. (a :->: b) -> K1 i a x :->: b
K1Trie ((a -> b) -> a :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (K1 i a x -> b
f (K1 i a x -> b) -> (a -> K1 i a x) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a x
forall k i c (p :: k). c -> K1 i c p
K1)) 
  untrie :: (K1 i a x :->: b) -> K1 i a x -> b
untrie (K1Trie t) = \(K1 a
a) -> ((a :->: b) -> a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie a :->: b
t) a
a 
  enumerate :: (K1 i a x :->: b) -> [(K1 i a x, b)]
enumerate (K1Trie t) = (a -> K1 i a x) -> (a :->: b) -> [(K1 i a x, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' a -> K1 i a x
forall k i c (p :: k). c -> K1 i c p
K1 a :->: b
t 

-- | wraps @f x@ 
instance (HasTrie (f x)) => HasTrie (M1 i t f x) where
  data (M1 i t f x :->: b) = M1Trie (f x :->: b) 
  trie :: (M1 i t f x -> b) -> M1 i t f x :->: b
trie M1 i t f x -> b
f = (f x :->: b) -> M1 i t f x :->: b
forall i (t :: Meta) (f :: * -> *) x b.
(f x :->: b) -> M1 i t f x :->: b
M1Trie ((f x -> b) -> f x :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (M1 i t f x -> b
f (M1 i t f x -> b) -> (f x -> M1 i t f x) -> f x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> M1 i t f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1)) 
  untrie :: (M1 i t f x :->: b) -> M1 i t f x -> b
untrie (M1Trie t) = \(M1 f x
a) -> ((f x :->: b) -> f x -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie f x :->: b
t) f x
a  
  enumerate :: (M1 i t f x :->: b) -> [(M1 i t f x, b)]
enumerate (M1Trie t) = (f x -> M1 i t f x) -> (f x :->: b) -> [(M1 i t f x, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' f x -> M1 i t f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f x :->: b
t 

-- | the data type in a __reg__ular form. 
-- "unlifted" generic representation. (i.e. is a unary type constructor). 
type Reg a = Rep a () 

-- | 'Generic'-friendly default for 'trie'
trieGeneric :: (Generic a, HasTrie (Reg a))
            => ((Reg a :->: b) -> (a :->: b))
            -> (a -> b)
            -> (a :->: b)
trieGeneric :: ((Reg a :->: b) -> a :->: b) -> (a -> b) -> a :->: b
trieGeneric (Reg a :->: b) -> a :->: b
theConstructor a -> b
f = (Reg a :->: b) -> a :->: b
theConstructor ((Reg a -> b) -> Reg a :->: b
forall a b. HasTrie a => (a -> b) -> a :->: b
trie (a -> b
f (a -> b) -> (Reg a -> a) -> Reg a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reg a -> a
forall a x. Generic a => Rep a x -> a
to))
{-# INLINEABLE trieGeneric #-}

-- | 'Generic'-friendly default for 'untrie'
untrieGeneric :: (Generic a, HasTrie (Reg a))
              => ((a :->: b) -> (Reg a :->: b))
              -> (a :->: b)
              -> (a -> b)
untrieGeneric :: ((a :->: b) -> Reg a :->: b) -> (a :->: b) -> a -> b
untrieGeneric (a :->: b) -> Reg a :->: b
theDestructor a :->: b
t = \a
a -> ((Reg a :->: b) -> Reg a -> b
forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ((a :->: b) -> Reg a :->: b
theDestructor a :->: b
t)) (a -> Reg a
forall a x. Generic a => a -> Rep a x
from a
a)
{-# INLINEABLE untrieGeneric #-}

-- | 'Generic'-friendly default for 'enumerate'
enumerateGeneric :: (Generic a, HasTrie (Reg a))
                 => ((a :->: b) -> (Reg a :->: b))
                 -> (a :->: b)
                 -> [(a, b)]
enumerateGeneric :: ((a :->: b) -> Reg a :->: b) -> (a :->: b) -> [(a, b)]
enumerateGeneric (a :->: b) -> Reg a :->: b
theDestructor a :->: b
t = (Reg a -> a) -> (Reg a :->: b) -> [(a, b)]
forall a a' b. HasTrie a => (a -> a') -> (a :->: b) -> [(a', b)]
enum' Reg a -> a
forall a x. Generic a => Rep a x -> a
to ((a :->: b) -> Reg a :->: b
theDestructor a :->: b
t) 
{-# INLINEABLE enumerateGeneric #-}

dropProduct :: (f :*: g) a -> (f a, g a) 
dropProduct :: (:*:) f g a -> (f a, g a)
dropProduct (f a
a :*: g a
b) = (f a
a, g a
b)
{-# INLINEABLE dropProduct #-}

liftProduct :: (f a, g a) -> (f :*: g) a 
liftProduct :: (f a, g a) -> (:*:) f g a
liftProduct (f a
a, g a
b) = (f a
a f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
b)
{-# INLINEABLE liftProduct #-}

dropSum :: (f :+: g) a -> Either (f a) (g a) 
dropSum :: (:+:) f g a -> Either (f a) (g a)
dropSum (:+:) f g a
s = case (:+:) f g a
s of 
              L1 f a
x -> f a -> Either (f a) (g a)
forall a b. a -> Either a b
Left f a
x 
              R1 g a
x -> g a -> Either (f a) (g a)
forall a b. b -> Either a b
Right g a
x 
{-# INLINEABLE dropSum #-}

liftSum :: Either (f a) (g a) -> (f :+: g) a 
liftSum :: Either (f a) (g a) -> (:+:) f g a
liftSum = (f a -> (:+:) f g a)
-> (g a -> (:+:) f g a) -> Either (f a) (g a) -> (:+:) f g a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1
{-# INLINEABLE liftSum #-}