summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLouisWasserman <>2011-01-06 21:41:04 (GMT)
committerLuite Stegeman <luite@luite.com>2011-01-06 21:41:04 (GMT)
commit38bef6d391b1d51b86bb5b907eaec7c944b24ff2 (patch)
tree40b1303948a82101d40a3075cbad35851ac14004
parent3179a56a0999a1e43446e29da4a1deb0ba411585 (diff)
version 0.7.00.7.0
-rw-r--r--Data/TrieMap/Applicative.hs17
-rw-r--r--Data/TrieMap/Class/Instances.hs1
-rw-r--r--Data/TrieMap/Representation/TH.hs196
-rw-r--r--TrieMap.cabal6
4 files changed, 159 insertions, 61 deletions
diff --git a/Data/TrieMap/Applicative.hs b/Data/TrieMap/Applicative.hs
index 5962575..4971297 100644
--- a/Data/TrieMap/Applicative.hs
+++ b/Data/TrieMap/Applicative.hs
@@ -11,10 +11,19 @@ import Data.Monoid hiding (Dual)
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)
diff --git a/Data/TrieMap/Class/Instances.hs b/Data/TrieMap/Class/Instances.hs
index cdc6e9d..c4637ff 100644
--- a/Data/TrieMap/Class/Instances.hs
+++ b/Data/TrieMap/Class/Instances.hs
@@ -22,6 +22,7 @@ import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Instances
-- import Data.TrieMap.UnionMap()
import Data.TrieMap.UnitMap()
+import Data.TrieMap.Key
import Data.Bits
import Data.Char
diff --git a/Data/TrieMap/Representation/TH.hs b/Data/TrieMap/Representation/TH.hs
index 06a247d..4c0c565 100644
--- a/Data/TrieMap/Representation/TH.hs
+++ b/Data/TrieMap/Representation/TH.hs
@@ -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
-
--- 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) [])
-
--- 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, \ No newline at end of file
+data ToRepCase = ToRepCase [Pat] Exp
+data FromRepCase = FromRepCase Pat [Exp]
+type ToRep = [ToRepCase]
+type FromRep = [FromRepCase]
+
+type Representation = (Type, ToRep, FromRep)
+
+-- | 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
diff --git a/TrieMap.cabal b/TrieMap.cabal
index 2d1f604..feb1157 100644
--- a/TrieMap.cabal
+++ b/TrieMap.cabal
@@ -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,