diff --git a/Data/TrieMap/Applicative.hs b/Data/TrieMap/Applicative.hs --- a/Data/TrieMap/Applicative.hs +++ b/Data/TrieMap/Applicative.hs @@ -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) diff --git a/Data/TrieMap/Class/Instances.hs b/Data/TrieMap/Class/Instances.hs --- a/Data/TrieMap/Class/Instances.hs +++ b/Data/TrieMap/Class/Instances.hs @@ -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 diff --git a/Data/TrieMap/Representation/TH.hs b/Data/TrieMap/Representation/TH.hs --- 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 +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 diff --git a/TrieMap.cabal b/TrieMap.cabal --- 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,