packages feed

TrieMap 0.6.3 → 0.7.0

raw patch · 4 files changed

+157/−59 lines, 4 filesdep +th-expand-synsdep ~template-haskell

Dependencies added: th-expand-syns

Dependency ranges changed: template-haskell

Files

Data/TrieMap/Applicative.hs view
@@ -11,10 +11,19 @@ newtype Id a = Id {unId :: a} newtype WM w m a = WM {runWM :: m (w, a)} -deriving instance Functor First-deriving instance Functor Last-deriving instance Monad First-deriving instance Monad Last+instance Functor First where+	fmap f (First m) = First (fmap f m)++instance Functor Last where+	fmap f (Last m) = Last (fmap f m)++instance Monad First where+	return = First . return+	First m >>= k = First (m >>= getFirst . k)++instance Monad Last where+	return = Last . return+	Last m >>= k = Last (m >>= getLast . k)  instance Functor m => Functor (WM w m) where 	fmap f (WM x) = WM (fmap (second f) x)
Data/TrieMap/Class/Instances.hs view
@@ -22,6 +22,7 @@ import Data.TrieMap.Regular.Instances -- import Data.TrieMap.UnionMap() import Data.TrieMap.UnitMap()+import Data.TrieMap.Key  import Data.Bits import Data.Char
Data/TrieMap/Representation/TH.hs view
@@ -1,63 +1,151 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, PatternGuards, DoAndIfThenElse #-} -module Data.TrieMap.Representation.TH  where+module Data.TrieMap.Representation.TH (genRepr) where  import Data.TrieMap.Rep.TH import Data.TrieMap.Rep import Data.TrieMap.Regular.Base+import Data.TrieMap.Key+import Data.TrieMap.Rep.Instances import Language.Haskell.TH+import Language.Haskell.TH.ExpandSyns import Control.Arrow import Control.Monad -type RepInfo = (Q Type, Q Exp, Q Exp)-	-- RepInfo t = (t', t -> t', t' -> t)--- inferRepresentation :: Name -> String -> Q [Dec]--- inferRepresentation k kRepName = do+data ToRepCase = ToRepCase [Pat] Exp+data FromRepCase = FromRepCase Pat [Exp]+type ToRep = [ToRepCase]+type FromRep = [FromRepCase] --- conToMatch :: Name -> Int -> Q Match--- conToMatch con [] = return (Match (ConP con []) (NormalB (ConE ''U0)) [])--- conToMatch con ts = --- 	do	varTs <- replicateM ts (newName "a")--- 		let pat = ConP con (map (VarP . fst) varTs)--- 		--- 		let bod = NormalB (prod [ConE 'toRep `AppE` (VarE x) | (x, _) <- varTs])--- 		return (Match pat bod [])--- 	where	prod [x] = x--- 		prod (x:xs) = ConE (mkName ":*:") `AppE` x `AppE` prod xs--- --- infixConToMatch :: Name -> Q Match--- infixConToMatch con = do--- 	a <- newName "a"--- 	b <- newName "b"--- 	let ae = varE a--- 	let be = varE b--- 	b <- [| toRep $ae :*: toRep $be |]--- 	return (Match (InfixP (VarP a) con (VarP b)) (NormalB b) [])+type Representation = (Type, ToRep, FromRep) --- conToRep :: Type -> [Type] -> RepInfo--- conToRep _ [] = (conT ''U0, [| const U0 |], [| const U0 |])--- conToRep t [x]--- 	| x == t	= (conT ''I0, [| I0 |], [| unI0 |])--- 	| otherwise	= (conT ''K0 `appT` x, [| K0 |], [| unK0 |])--- conToRep t (arg0:args) = case conToRep t args of--- 	(tArgs, toArgs, fromArgs)--- 		| arg0 == t	-> (conT '':*: `appT` conT ''I0 `appT` tArgs, [| \ (a, b) -> (I0 a, $toArgs b) |],--- 		 			[| \ (I0 a, b) -> (a, $fromArgs b) |])--- 		| otherwise	-> (conT '':*: `appT` (conT ''K0 `appT` --- 	where	toTuple [(_, x), (_, y)] = TupleT 2 `AppT` x `AppT` y--- 		--- --- product :: Q Exp -> Q Exp -> RepInfo -> RepInfo -> RepInfo--- product inj outj (t1, to1, from1) (t2, to2, from2) = --- 	(tupleT 2 `appT` t1 `appT` t2,--- 		[| ($to1 *** $to2) . $outj |],--- 		[| $inj . ($from1 *** $from2) |])--- --- sum :: Q Exp -> Q Exp -> RepInfo -> RepInfo -> RepInfo--- sum inj outj (t1, to1, from1) (t2, to2, from2) = --- 	(conT ''Either `appT` t1 `appT` t2,--- 		[| ($to1 +++ $to2) . $outj |],--- 		[| $inj ($from1 +++ $from2) |])--- repInstances :: Set Name--- repInstances = fromList [''Int, ''Bool, ''Char, ''Double, ''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Word, ''Word8,--- 	''Word16, ''Word32, ''Word64, ''(), ''ByteString, ''IntSet, +-- | Given the name of a type constructor, automatically generates an efficient 'Repr' instance.  /Warning/: Generalized tries do not work for "infinitely complicated types," for example, a type-system construction of the natural numbers.+-- In these cases, a context reduction stack overflow will occur at compile time when you use the 'TKey' instance for that type.+genRepr :: Name -> Q [Dec]+genRepr tycon = do+	TyConI dec <- reify tycon+	case dec of+		DataD _ _ tyvars cons _ -> do+			conReprs <- mapM conRepr cons+			return (decsForRepr (foldl AppT (ConT tycon) (map tyVarBndrType tyvars)) (foldr1 union conReprs))+		NewtypeD _ _ tyvars con _ -> do+			theConRepr <- conRepr con+			return (decsForRepr (foldl AppT (ConT tycon) (map tyVarBndrType tyvars)) theConRepr)++tyVarBndrType :: TyVarBndr -> Type+tyVarBndrType (PlainTV tyvar) = VarT tyvar+tyVarBndrType (KindedTV tyvar _) = VarT tyvar++decsForRepr :: Type -> Representation -> [Dec]+decsForRepr t (tRep, toR, fromR) = [+		TySynInstD ''Rep [t] tRep,+		InstanceD [] (ConT ''Repr `AppT` t)+			[FunD 'toRep+				[Clause pats (NormalB e) [] | ToRepCase pats e <- toR],+			 FunD 'fromRep+				[Clause [pat] (NormalB e) [] | FromRepCase pat [e] <- fromR]]]++decompose :: Type -> (Type, [Type])+decompose (tyfun `AppT` ty) = case decompose tyfun of+	(tyfun, tys)	-> (tyfun, tys ++ [ty])+decompose ty = (ty, [])++type ReprM = Q++conRepr :: Con -> ReprM Representation+conRepr (RecC con args) = conRepr (NormalC con [(strict, typ) | (_, strict, typ) <- args])+conRepr (InfixC t1 con t2) = conRepr (NormalC con [t1, t2])+conRepr (NormalC con []) = return $ conify con unit+conRepr (NormalC con args) = do+	argCons <- mapM (typeRepr . snd) args+	return (conify con (foldr1 prod argCons))++typeRepr :: Type -> ReprM Representation+typeRepr t00 = expandSyns t00 >>= \ t0 -> case decompose t0 of+	(ListT, [t])	-> do+		(tRep, toR, fromR) <- typeRepr t+		xs <- newName "elems"+		x <- newName "el"+		xsRep <- newName "elemReps"+		xRep <- newName "elemRep"+		return (ListT `AppT` tRep,+			[ToRepCase [VarP xs] +				(CompE [BindS (VarP x) (VarE xs),+					NoBindS (CaseE (VarE x) [Match pat (NormalB e) [] | ToRepCase [pat] e <- toR])])],+			[FromRepCase (VarP xsRep)+				[CompE [BindS (VarP xRep) (VarE xsRep),+					NoBindS (CaseE (VarE xRep) [Match pat (NormalB e) [] | FromRepCase pat [e] <- fromR])]]])+	(TupleT 0, _)	-> return unit+	(TupleT n, ts)	-> do+		reps <- mapM typeRepr ts+		let (tRep, toR, fromR) = foldr1 prod reps+		return (tRep, [ToRepCase [TupP pats] e | ToRepCase pats e <- toR], [FromRepCase pat [TupE es] | FromRepCase pat es <- fromR])+	(ConT con, ts)+		| con == ''()	-> return unit+		| con == ''Either, [tL, tR] <- ts+			-> do	(tRepL, lToR, lFromR) <- typeRepr tL+				(tRepR, rToR, rFromR) <- typeRepr tR+				return (ConT ''Either `AppT` tRepL `AppT` tRepR,+					[ToRepCase [ConP 'Left pats] (ConE 'Left `AppE` e) | ToRepCase pats e <- lToR] +++						[ToRepCase [ConP 'Right pats] (ConE 'Right `AppE` e) | ToRepCase pats e <- rToR],+					[FromRepCase (ConP 'Left [pat]) [ConE 'Left `AppE` e] | FromRepCase pat [e] <- lFromR] +++						[FromRepCase (ConP 'Right [pat]) [ConE 'Right `AppE` e] | FromRepCase pat [e] <- rFromR])+		| con == ''Maybe, [t] <- ts+			-> do	(tRep, toR, fromR) <- typeRepr t+				return (ConT ''Either `AppT` TupleT 0 `AppT` tRep,+					[ToRepCase [ConP 'Nothing []] (ConE 'Left `AppE` TupE [])] +++						[ToRepCase [ConP 'Just pats] (ConE 'Right `AppE` e) | ToRepCase pats e <- toR],+					[FromRepCase (RecP 'Left []) [ConE 'Nothing]] +++						[FromRepCase (ConP 'Right [pat]) [ConE 'Just `AppE` e] | FromRepCase pat [e] <- fromR])+		| otherwise -> do+					ClassI _ instances <- reify ''Repr+					let knowns = [tycon | ClassInstance{ci_tys = [ConT tycon]} <- instances]+					if con `elem` knowns && null ts then do+						arg <- newName "arg"+						argRep <- newName "argRep"+						return (ConT ''Rep `AppT` ConT con,+							[ToRepCase [VarP arg] (VarE 'toRep `AppE` VarE arg)],+							[FromRepCase (VarP argRep) [VarE 'fromRep `AppE` VarE argRep]])+					else recursiveRepr t0+	_	-> recursiveRepr t0++tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV n) = n+tyVarBndrName (KindedTV n _) = n++recursiveRepr :: Type -> ReprM Representation+recursiveRepr t0 = do	-- TODO: handle type synonyms here+		x <- newName "arg"+		return (ConT ''Key `AppT` t0, +			[ToRepCase [VarP x] (ConE 'Key `AppE` VarE x)],+			[FromRepCase (ConP 'Key [VarP x]) [VarE x]])++unit :: Representation+unit = (TupleT 0, [ToRepCase [] (TupE [])], [FromRepCase WildP []])++prod :: Representation -> Representation -> Representation+prod (t1, toRep1, fromRep1)+	(t2, toRep2, fromRep2) =+	(TupleT 2 `AppT` t1 `AppT` t2,+		do	ToRepCase pats1 out1 <- toRep1+			ToRepCase pats2 out2 <- toRep2+			return (ToRepCase (pats1 ++ pats2) (TupE [out1, out2])),+		do	FromRepCase pat1 out1 <- fromRep1+			FromRepCase pat2 out2 <- fromRep2+			return (FromRepCase (TupP [pat1, pat2]) (out1 ++ out2)))++conify :: Name -> Representation -> Representation+conify conName (t, toR, fromR) =+	(t, [ToRepCase [ConP conName args] e | ToRepCase args e <- toR], [FromRepCase p [foldl AppE (ConE conName) outs] | FromRepCase p outs <- fromR])++union :: Representation -> Representation -> Representation+union (t1, toRep1, fromRep1)+	(t2, toRep2, fromRep2) =+	(ConT ''Either `AppT` t1 `AppT` t2,+		[ToRepCase pats (ConE 'Left `AppE` e) | ToRepCase pats e <- toRep1] +++		[ToRepCase pats (ConE 'Right `AppE` e) | ToRepCase pats e <- toRep2],+		[FromRepCase (ConP 'Left [pat]) es | FromRepCase pat es <- fromRep1] +++		[FromRepCase (ConP 'Right [pat]) es | FromRepCase pat es <- fromRep2])++-- genRepInstance :: Type -> Representationesentation -> Q Dec+-- genInstance
TrieMap.cabal view
@@ -1,14 +1,14 @@ name:		     TrieMap-version:             0.6.3+version:             0.7.0 tested-with:	     GHC category:            Algorithms synopsis:	     Automatic type inference of generalized tries.-description:	     Builds on the multirec library to create a system capable of automatic or simple generalized trie type inference.+description:	     Builds on the multirec library to create a system capable of automatic or simple generalized trie type inference.  Uses Template Haskell to automatically derive a TKey instance for almost any datatype. license:             BSD3 license-file:	     LICENSE author:              Louis Wasserman maintainer:          wasserman.louis@gmail.com-build-Depends:       base < 5.0.0.0, containers, multirec, template-haskell, bytestring, array+build-Depends:       base < 5.0.0.0, containers, multirec, template-haskell >= 2.5.0.0, bytestring, array, th-expand-syns >= 0.1.1.0 build-type:	     Simple exposed-modules:   	Data.TrieMap,