Commit 07388af8 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

Drop `template-haskell`'s build-dep on `containers`

This is an attempt to address

  https://github.com/haskell/cabal/issues/1811



by replicating the less than 100 lines of code actually used from the
containers package into an internal non-exposed `template-haskell` module.

Moreover, `template-haskell` does not expose the `Map` type, so this change
should have no visible effect on the public API.

It may turn out that `Data.Map` is not necessary and that even a simple
list-based associative list (`Prelude.lookup`) may suffice. However, in
order to avoid any regressions, this commit takes the safe route and just
clones `Data.Map` for now.
Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parent 4ceb5dec
{-# LANGUAGE BangPatterns #-}
-- This is a non-exposed internal module
--
-- The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost
-- verbatimely to avoid a dependency of 'template-haskell' on the containers package.
--
-- [1] see https://hackage.haskell.org/package/containers-0.5.5.1
--
-- The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al.
module Language.Haskell.TH.Lib.Map
( Map
, empty
, insert
, Language.Haskell.TH.Lib.Map.lookup
) where
data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
| Tip
type Size = Int
empty :: Map k a
empty = Tip
{-# INLINE empty #-}
singleton :: k -> a -> Map k a
singleton k x = Bin 1 k x Tip Tip
{-# INLINE singleton #-}
size :: Map k a -> Int
size Tip = 0
size (Bin sz _ _ _ _) = sz
{-# INLINE size #-}
lookup :: Ord k => k -> Map k a -> Maybe a
lookup = go
where
go _ Tip = Nothing
go !k (Bin _ kx x l r) = case compare k kx of
LT -> go k l
GT -> go k r
EQ -> Just x
{-# INLINABLE lookup #-}
insert :: Ord k => k -> a -> Map k a -> Map k a
insert = go
where
go :: Ord k => k -> a -> Map k a -> Map k a
go !kx x Tip = singleton kx x
go !kx x (Bin sz ky y l r) =
case compare kx ky of
LT -> balanceL ky y (go kx x l) r
GT -> balanceR ky y l (go kx x r)
EQ -> Bin sz kx x l r
{-# INLINABLE insert #-}
balanceL :: k -> a -> Map k a -> Map k a -> Map k a
balanceL k x l r = case r of
Tip -> case l of
Tip -> Bin 1 k x Tip Tip
(Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip
(Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)
(Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)
(Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))
| lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)
| otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)
(Bin rs _ _ _ _) -> case l of
Tip -> Bin (1+rs) k x Tip r
(Bin ls lk lx ll lr)
| ls > delta*rs -> case (ll, lr) of
(Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)
| lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)
| otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)
(_, _) -> error "Failure in Data.Map.balanceL"
| otherwise -> Bin (1+ls+rs) k x l r
{-# NOINLINE balanceL #-}
balanceR :: k -> a -> Map k a -> Map k a -> Map k a
balanceR k x l r = case l of
Tip -> case r of
Tip -> Bin 1 k x Tip Tip
(Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r
(Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr
(Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)
(Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))
| rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr
| otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
(Bin ls _ _ _ _) -> case r of
Tip -> Bin (1+ls) k x l Tip
(Bin rs rk rx rl rr)
| rs > delta*ls -> case (rl, rr) of
(Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)
| rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr
| otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
(_, _) -> error "Failure in Data.Map.balanceR"
| otherwise -> Bin (1+ls+rs) k x l r
{-# NOINLINE balanceR #-}
delta,ratio :: Int
delta = 3
ratio = 2
......@@ -40,8 +40,8 @@ import Language.Haskell.TH.Syntax
import qualified Text.PrettyPrint as HPJ
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, liftM2, ap)
import Data.Map ( Map )
import qualified Data.Map as Map ( lookup, insert, empty )
import Language.Haskell.TH.Lib.Map ( Map )
import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty )
import GHC.Base (Int(..))
infixl 6 <>
......
......@@ -42,9 +42,11 @@ Library
Language.Haskell.TH.Quote
Language.Haskell.TH.Syntax
other-modules:
Language.Haskell.TH.Lib.Map
build-depends:
base == 4.7.*,
containers == 0.5.*,
pretty == 1.1.*
-- We need to set the package name to template-haskell (without a
......
......@@ -2,15 +2,14 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
T :: k -> *
data T (k::BOX) (a::k)
No C type associated
Roles: [nominal, representational]
RecFlag NonRecursive, Not promotable
=
FamilyInstance: none
No C type associated
Roles: [nominal, representational]
RecFlag NonRecursive, Not promotable
=
FamilyInstance: none
COERCION AXIOMS
Dependent modules: []
Dependent packages: [array-0.5.0.0, base, containers-0.5.5.1,
deepseq-1.3.0.2, ghc-prim, integer-gmp, pretty-1.1.1.1,
Dependent packages: [base, ghc-prim, integer-gmp, pretty-1.1.1.1,
template-haskell]
==================== Typechecker ====================
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment