diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,33 @@ +Copyright (c) 2010, Peter Findeisen, Frank Huch, Sebastian Fischer, +Andreas Baldeau + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/runghc + +import Distribution.Simple +main = defaultMain diff --git a/derive-trie.cabal b/derive-trie.cabal new file mode 100644 --- /dev/null +++ b/derive-trie.cabal @@ -0,0 +1,50 @@ +Name: derive-trie +Version: 0.1.0 +Stability: Provisional +Synopsis: Automatic derivation of Trie implementations. +Description: Automatic derivation of Trie implementations from user + defined key types with Template Haskell. Uses KeyMap class + as interface for tries. +License: BSD3 +License-file: LICENSE +Author: Peter Findeisen, Frank Huch, Sebastian Fischer, Andreas Baldeau +Maintainer: Andreas Baldeau +Homepage: http://github.com/baldo/derive-trie +Bug-Reports: http://github.com/baldo/derive-trie/issues +Category: Data +Build-Type: Simple +Tested-With: GHC == 6.12.3 +Cabal-Version: >= 1.8 + +Extra-Source-Files: + Setup.hs + README + examples/TreeTrie.hs + +Source-Repository head + Type: git + Location: git://github.com/baldo/derive-trie.git + +Library + Build-Depends: + base == 4.*, + array == 0.3.*, + containers == 0.3.*, + template-haskell == 2.4.* + + Ghc-Options: + -Wall + + Hs-Source-Dirs: + src + + Exposed-modules: + Data.Derive.Trie, + Data.KeyMap + + Extensions: + FlexibleInstances + FunctionalDependencies + MultiParamTypeClasses + TemplateHaskell + UndecidableInstances diff --git a/examples/TreeTrie.hs b/examples/TreeTrie.hs new file mode 100644 --- /dev/null +++ b/examples/TreeTrie.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE + MultiParamTypeClasses, + TemplateHaskell, + TypeSynonymInstances, + UndecidableInstances + #-} + +module TreeTrie where + +import Prelude hiding (lookup) + +import Data.Derive.Trie +import Data.KeyMap + +data Tree a = Leaf a | Node (Tree a) (Tree a) + +type IntTree = Tree Int + +deriveTrie [''IntTree] + +t1 = insert (Leaf 3) "first" (empty :: IntTreeTrie String) +t2 = insert (Node (Leaf 1) (Leaf 2)) "second" t1 + +main = do + print $ lookup (Leaf 1) t2 + print $ lookup (Leaf 3) t2 + print $ lookup (Node (Leaf 2) (Leaf 1)) t2 + print $ lookup (Node (Leaf 1) (Leaf 2)) t2 + diff --git a/src/Data/Derive/Trie.hs b/src/Data/Derive/Trie.hs new file mode 100644 --- /dev/null +++ b/src/Data/Derive/Trie.hs @@ -0,0 +1,1250 @@ +{-# LANGUAGE + TemplateHaskell, + UndecidableInstances + #-} + +{-# OPTIONS_GHC + -fno-warn-incomplete-patterns + -fno-warn-missing-signatures + -fno-warn-name-shadowing + -fno-warn-unused-matches + #-} + +{- | This module provides the template to automatically derive a + Trie implementation from a data type, which uses this data type + as key. The template generates a trie data type and an instance of the + 'KeyMap' class for every given key, as described in the paper + \"Efficient, Modular Tries\" by Sebastian Fischer and Frank Huch is + generated using Template Haskell. + + Usage: + + > import Data.Derive.Trie + > import Data.KeyMap + > ... + > $(deriveTrie ['','',..]) + + You will also need to enable the following language extensions: + + - MultiParamTypeClasses + - TemplateHaskell + - UndecidableInstances + + And if you want to derive Tries structures for type synonyms you will also + need: + + - TypeSynonymInstances + -} +module Data.Derive.Trie + ( + -- * Deriving Trie structures + deriveTrie + + -- * Used in generated code + , tidy + , ensureTrie + , trieToMaybe +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Data.Maybe (fromMaybe,isJust,fromJust) +import Control.Monad (foldM) +import Data.List (nub,nubBy,find) +import Debug.Trace +import Data.KeyMap (KeyMap) +import qualified Data.KeyMap as KeyMap +import qualified Data.Map +import qualified Data.IntMap +import Data.Array + + +-- trie types for some primitive types like Int,Char, .. +prim2trie :: [(Type,Type)] +prim2trie = [(ConT ''Int, ConT ''Data.IntMap.IntMap), + (ConT ''Char, AppT (ConT ''Data.Map.Map) (ConT ''Char)), + (ConT ''Float, AppT (ConT ''Data.Map.Map) (ConT ''Float)), + (ConT ''Double, AppT (ConT ''Data.Map.Map) (ConT ''Double)), + (ConT ''Array, AppT (ConT ''Data.Map.Map) (ConT ''Array)) + ] +-- names for the built-in types, whose names would be invalid in user code, +-- e.g. '[]Trie' is a illegal name +nonStandardTrieNamesForKeys :: [(Name,String)] +nonStandardTrieNamesForKeys = + [(''(),"UnitTrie"),(''[],"ListTrie"),(''(,),"T2Trie"),(''(,,),"T3Trie"), + (''(,,,),"T4Trie"),(''(,,,,),"T5Trie"),(''(,,,,,),"T6Trie"), + (''(,,,,,,),"T7Trie") + ] + + +-- list of the classes names, which shall occur in the 'deriving' clause +-- empty, because compiling 'deriving' with flag +-- '-fallow-undecidable-instances' traps in ghc-bug (ghc6.6) +classesToDeriveFrom :: [Name] +classesToDeriveFrom = [] --[''Show,''Eq,''Ord] + +-- for (Show a, Eq a,..) +standardCxt :: [Name] -> Cxt +standardCxt typevarnames = + concatMap ((flip mkCxtForClass) typevarnames) classesToDeriveFrom + +-- mkCxtForClass ''Eq [a,b] -> (Eq a, Eq b) +mkCxtForClass :: Name -> [Name] -> Cxt +mkCxtForClass _ [] = [] +mkCxtForClass classname (t:ts) = + ClassP classname [VarT t] : mkCxtForClass classname ts + +-- main template of this module, for each name given, it builds the data and +-- instance declaration for a trie with the data type noted by the name as key. +-- Further, some helper functions are brought into scope. +-- This template must be called only once within a module, otherwise name +-- clashes are inevitable. +deriveTrie :: [Name] -> Q [Dec] +deriveTrie [] = return [] +deriveTrie names = do + keyDecs <- mapM getDecOfName names + trieAndInstanceDecs <- mapM deriveTrie' keyDecs + ns <- mapM getMaxN keyDecs + let maxn = maximum ns + lookupnDecs <- mapM lookupnD [0..maxn] + alternDecs <- mapM alternD [0..maxn] + combinenDecs <- mapM combinenD [0..maxn] + mapMaybeWithKeynDecs <- mapM mapMaybeWithKeynD [0..maxn] + toListnDecs <- mapM toListnD [0..maxn] + return (nubBy eqDec (concat trieAndInstanceDecs) ++ + lookupnDecs ++ alternDecs ++ concat combinenDecs ++ + mapMaybeWithKeynDecs ++ toListnDecs) + +-- get name's type declaration +getDecOfName :: Name -> Q Dec +getDecOfName name = do + info <- reify name + case info of + TyConI dec -> return dec + _ -> error "getDecOfName: type constructor expected!" + +-- generates the data and instance declaration for a trie with keyDec as key +deriveTrie' :: Dec -> Q [Dec] +deriveTrie' keyDec = do -- Q Monade + --trace ("derive: "++ nameBase (getNameOfDec keyDec)) (return ()) + (key2trie,trie2keyDecs) <- genTrieDatastructure prim2trie [] keyDec + let trieDecs = map fst trie2keyDecs + keyDecs = map snd trie2keyDecs + -- sometimes, e.g. when building a Pattern, a dataCon is needed + -- with type synonyms you may need reify on recently generated types + -- because this is not possible in TH, the list knownDecs is needed + -- it is used by getConstrsOfDataDec + knownDecs = trieDecs ++ keyDecs + -- log messages to see, what has been generated. + -- fixxme: does not show used built-in tries + keyNames = map (nameBase . getNameOfDec . snd) trie2keyDecs + triePPrints = map (pprint . fst) trie2keyDecs + loglines = map (\ (t,k) -> k ++ " --> " ++ t) + (zip triePPrints keyNames) + trace (unlines loglines) (return ()) + --trace ("\n" ++ unlines (map (show . fst) trie2keyDecs)) (return ()) + --trace ("\n" ++ unlines (map (show . snd) trie2keyDecs)) (return ()) + instanceDecs <- mapM (uncurry (genKeyMapInstanceDec knownDecs key2trie)) + trie2keyDecs + return (trieDecs ++ concat instanceDecs ) + -- ++ lookupnDecs ++ alternDecs ++ (concat combinenDecs)) + +-- get the maximal arity of all data constructors. is needed to determine max +-- argument of lookupn, altern and combinen. +getMaxN :: Dec -> Q Int +getMaxN dec = getMaxN' [] 0 dec + +getMaxN' :: [Name] -> Int -> Dec -> Q Int +getMaxN' visiteds n dec = do + let name = getNameOfDec dec + if elem name visiteds + then return n + else do cons <- getConstrsOfDataDec [] dec + let types = map getTypesInCon cons + maxn = maximum (n : map length types) + conTypes = + filter isConT (nub (concatMap getBaseTypes (concat types))) + mconDecs <- mapM (getDecOfType []) conTypes + let conDecs = map fromJust (filter isJust mconDecs) + maxns <- mapM (getMaxN' (name : visiteds) maxn) conDecs + return (maximum (maxn:maxns)) + +-- get arities of constructors +getNs :: Dec -> Q [Int] +getNs keyDec = do cons <- getConstrsOfDataDec [] keyDec + return (map length (map getTypesInCon cons)) + + +-- generates the trie for the given key. +-- key2trie maps keys to already generated tries, +-- knownTrieDecs lists known tries, for lookup in case they need to be reified +genTrieDatastructure :: [(Type,Type)] -> [Dec] -> Dec + -> Q ([(Type,Type)],[(Dec,Dec)]) +genTrieDatastructure key2trie knownTrieDecs keyDec = + --trace ("genTrieDatastructure:\n " ++ show key2trie ++ "\n " ++ show knownTrieDecs ++ "\n "++ show keyDec ++ "\n\n") $ + case keyDec of + TySynD keyName keyTypeVarNames keyType -> do + if isJust (lookup (ConT keyName) key2trie) + then return (key2trie,[]) + else do + let trieBaseName = mkTrieBaseName keyName + (key2trie',decs,names) <- + genTrieDataHelper key2trie knownTrieDecs keyName keyTypeVarNames + [[keyType]] + let knownTrieDecs' = map fst decs ++ knownTrieDecs + trieDec <- mkTrieNewtypeDec knownTrieDecs' key2trie' trieBaseName + names keyType + return (key2trie', (trieDec,keyDec) : decs) + + NewtypeD _ keyName keyTypeVarNames con _ -> do + if isJust (lookup (ConT keyName) key2trie) + then return (key2trie,[]) + else do + let [keyType] = getTypesInCon con + trieBaseName = mkTrieBaseName keyName + --trieName = mkName trieBaseName + (key2trie',decs,names) <- + genTrieDataHelper key2trie knownTrieDecs keyName keyTypeVarNames + [[keyType]] + let knownTrieDecs' = map fst decs ++ knownTrieDecs + trieDec <- mkTrieNewtypeDec knownTrieDecs' key2trie' trieBaseName names + keyType + return (key2trie',(trieDec,keyDec) : decs) + + DataD _ keyName keyTypeVarNames constrs _ -> + if isJust (lookup (ConT keyName) key2trie) + then return (key2trie,[]) + else do + let types = map getTypesInCon constrs + trieBaseName = mkTrieBaseName keyName + trieName = mkName trieBaseName + knownTrieDecs' = dataDStub trieName : knownTrieDecs + (key2trie',decs,names) <- + genTrieDataHelper key2trie knownTrieDecs' keyName keyTypeVarNames types + let knownTrieDecs'' = map fst decs ++ knownTrieDecs' + trieDec <- mkTrieDataDec knownTrieDecs'' key2trie' trieBaseName names + types + return (key2trie',(trieDec,keyDec) : decs) + _ -> error "Can only derive from type, newtype or data declarations!" + +-- an empty data declaration +dataDStub :: Name -> Dec +dataDStub name = DataD [] name [] [] [] + + +-- helper for generating the trie datastructure, does the stuff common for +-- data declarations. typesynonyms and newtyps, namely: +-- returns the tries name,typevariables, decs of subtype's tries +genTrieDataHelper :: [(Type,Type)] -> [Dec] -> Name -> [TyVarBndr] -> [[Type]] + -> Q ([(Type,Type)],[(Dec,Dec)],(Name,[Name])) +genTrieDataHelper key2trie knownTrieDecs keyName keyTypeVarBndrs constrTypes = + do + --trace ("genTrieHelper: " ++ show key2trie ++ "\n" ++ show knownTrieDecs ++"\n" ++nameBase keyName ++ "\n") (return ()) + let keyType = ConT keyName + trieBaseName = mkTrieBaseName keyName + trieType = ConT (mkName trieBaseName) + -- for every type variable of the original type, a type variable for + -- the corresponding map is needed in trie type declaration (plus a + -- type variable for values stored in trie) + valName <- newName "val" + let keyTypeVarNames = map getNameFromBndr keyTypeVarBndrs + trieTypeVarNames = map getTrieTypeVar keyTypeVarNames + var2trie = zip keyTypeVarNames trieTypeVarNames + key2trie' = + [(keyType,trieType)] ++ + key2trie ++ (map (\(x,y) -> (VarT x,VarT y)) var2trie) + -- generate the tries for the suptypes + -- baseTypes should only contain VarTs and ConTs + baseTypes = + nub (concatMap getBaseTypes (nub (concat constrTypes))) + mbaseTypeDecs <- mapM (getDecOfType knownTrieDecs) + (filter isConT baseTypes) + let baseTypeDecs = map fromJust (filter isJust mbaseTypeDecs) + --trace ("genTrieHelper: " ++ show baseTypeDecs++ "\n") (return ()) + (key2trie'',decs) <- + foldM (\(k2t,ds) d ->do let ktd = knownTrieDecs ++ map fst ds + (k2t',ds') <- genTrieDatastructure k2t ktd d + return (k2t',ds' ++ ds)) + (key2trie',[]) + baseTypeDecs + return (key2trie'',decs,(valName,trieTypeVarNames)) + +-- using 'show' instead of 'nameBase' is here important,because: +-- show keyTypeVarName -> a_822037354 +-- nameBase keyTypeVarName -> a +-- using mkName instead of newName is also important, because the Decs of +-- built-in types like [] and (,) use identical typevars (a_822083586), which +-- can corrupt the key2trie lists: +-- [..(a_822083586,mapa_1627440534),(a_822083586,mapa_1627440537),..] +getTrieTypeVar :: Name -> Name +getTrieTypeVar keyTypeVarName = mkName ("map" ++ show keyTypeVarName) + +-- builds the basename of the trie for the given keyname +-- (usually (keyname ++"Trie)) +-- special, non standard key names,like [],(,),.. are replaced by special +-- trienames (ListTrie,T2Trie,..) +mkTrieBaseName :: Name -> String +mkTrieBaseName keyname = + let nonStandardName = lookup keyname nonStandardTrieNamesForKeys + in if isJust nonStandardName + then fromJust nonStandardName + else nameBase keyname ++ "Trie" + +-- builds from several data created before the trie's data declaration +mkTrieDataDec :: [Dec]->[(Type,Type)]-> String -> (Name,[Name]) -> [[Type]] + -> Q Dec +mkTrieDataDec knownTrieDecs key2trie trieBaseName (valName,trieTypeVarNames) + constrTypes = do + conFields <- mapM (mkConField knownTrieDecs valName key2trie) constrTypes + return (DataD (standardCxt (trieTypeVarNames ++ [valName])) + (mkName trieBaseName) + (map PlainTV $ trieTypeVarNames ++ [valName]) + [NormalC (mkName ("No" ++ trieBaseName)) [], + NormalC (mkName trieBaseName) conFields] + classesToDeriveFrom) + +-- builds from several data created before the trie's type synonym declaration +mkTrieTySynDec :: [Dec] ->[(Type,Type)] -> String -> (Name,[Name]) -> Type + -> Q Dec +mkTrieTySynDec knownTrieDecs key2trie trieBaseName (valName,trieTypeVarNames) + keyType = do + let unAppTrieTypeWithTySyns = replaceKeyByTrie key2trie keyType + unAppTrieType <- + replaceTySynTypesByDataType knownTrieDecs unAppTrieTypeWithTySyns + return (TySynD (mkName trieBaseName) + (map PlainTV $ trieTypeVarNames ++ [valName]) + (AppT unAppTrieType (VarT valName))) + +-- builds from several data created before the trie's newtype declaration +-- currently not in use +mkTrieNewtypeDec :: [Dec] ->[(Type,Type)] -> String -> (Name,[Name]) -> Type + -> Q Dec +mkTrieNewtypeDec knownTrieDecs key2trie trieBaseName (valName,trieTypeVarNames) + keyType = do + let unAppTrieTypeWithTySyns = replaceKeyByTrie key2trie keyType + unAppTrieType <- + replaceTySynTypesByDataType knownTrieDecs unAppTrieTypeWithTySyns + return (NewtypeD [] + (mkName trieBaseName) + (map PlainTV $ trieTypeVarNames ++ [valName]) + (RecC (mkName trieBaseName) + [(mkName ("un"++trieBaseName), + NotStrict, + AppT unAppTrieType (VarT valName))]) + []) + +-- in the given type, all type synonyms are replaced by the underlying data +-- types +replaceTySynTypesByDataType :: [Dec] -> Type -> Q Type +replaceTySynTypesByDataType knownTrieDecs t = do + let ot = getOutermostTypeOfType t + otArgs = getTypeArgs t + otArgs' <- mapM (replaceTySynTypesByDataType knownTrieDecs) otArgs + case ot of + ConT name -> do + let knownDec = find ((==name).getNameOfDec) knownTrieDecs + dec <- if isJust knownDec + then return (fromJust knownDec) + else do + info <- reify name + case info of + TyConI d -> return d + i -> error ("replaceTySynTypesByDataType: TyConI expected!\n"++ + show i) + case dec of + TySynD _ tvbndrs (AppT t' val) -> + let tvlist = map getNameFromBndr tvbndrs + tv2arg = zip (map VarT tvlist) otArgs' + in return (replaceArgs tv2arg t') + TySynD _ _ _ -> + error "replaceTySynTypesByDataType: invalid trie type synonym!" + _ -> return (applyTypes ot otArgs') + v -> do --trace ("in: "++ show t ++ "\nout: " ++ show (applyTypes ot otArgs') ++ "\n") (return ()) + return (applyTypes ot otArgs') + + +-- if the given type is an application from one type to some args, getTypeArgs +-- returns these args +getTypeArgs :: Type -> [Type] +getTypeArgs (AppT t1 t2) = getTypeArgs t1 ++ [t2] +getTypeArgs _ = [] + +-- applies type to args +applyTypes :: Type -> [Type] -> Type +applyTypes t [] = t +applyTypes t' (t:ts) = applyTypes (AppT t' t) ts + +-- replaces recursively types as specified in the assocList +replaceArgs :: [(Type,Type)] -> Type -> Type +replaceArgs assocList (AppT t1 t2) = + AppT (replaceArgs assocList t1) (replaceArgs assocList t2) +replaceArgs assocList t = + let t' = lookup t assocList + in if isJust t' + then fromJust t' + else t + +isConT :: Type -> Bool +isConT (ConT _) = True +isConT _ = False + +-- if the given type is a type constructor, it's declaration is returned, +-- otherwise Nothing +getDecOfType :: [Dec] -> Type -> Q (Maybe Dec) +getDecOfType knownDecs (ConT name) = do + let knownDec = find ((==name).getNameOfDec) knownDecs + if isJust knownDec + then return knownDec + else do + info <- reify name + case info of + TyConI tdec -> return (Just tdec) + _ -> return Nothing +getDecOfType _ _ = return Nothing + + +-- takes constructor of original datatype and returns corresponding field +-- for trie datatype +mkConField :: [Dec] -> Name -> [(Type,Type)] -> [Type] -> Q StrictType +mkConField knownTrieDecs valname key2trie types = do + --trace ("mkConField: " ++ show (mkConFieldType valname key2trie types)) + t <- mkConFieldType knownTrieDecs valname key2trie types + return (IsStrict,t) + +mkConFieldType :: [Dec] -> Name -> [(Type,Type)] -> [Type] -> Q Type +mkConFieldType knownTrieDecs valname key2trie types = do + let replace = + (replaceTySynTypesByDataType knownTrieDecs) . (replaceKeyByTrie key2trie) + trieTypesWithoutVal <- mapM replace types + let trieTypes = addVal trieTypesWithoutVal (VarT valname) + revTrieTypes = reverse trieTypes + fieldType = applyTypesAcc (tail revTrieTypes) (head revTrieTypes) + --trace ("mkConFieldType: " ++ show valname ++ " " ++ show types ++ "\n") + --replaceTySynTypesByDataType knownTrieDecs fieldType + return fieldType + + + +isAppT :: Type -> Bool +isAppT (AppT _ _) = True +isAppT _ = False + +-- replaces recursively every key type by the corresponding trie type, as +-- specified in key2trie +replaceKeyByTrie :: [(Type,Type)] -> Type -> Type +replaceKeyByTrie key2trie (AppT t1 t2) = + AppT (replaceKeyByTrie key2trie t1) (replaceKeyByTrie key2trie t2) +replaceKeyByTrie key2trie keyType = + fromMaybe (AppT (ConT ''Data.Map.Map) keyType) (lookup keyType key2trie) + +getTypesInCon :: Con -> [Type] +getTypesInCon (NormalC _ strictTypes) = map snd strictTypes +getTypesInCon (InfixC (_,t1) _ (_,t2)) = [t1,t2] +getTypesInCon (RecC _ varstrictTypes) = map (\(_,_,t) -> t) varstrictTypes +getTypesInCon (ForallC _ _ _) = + error "Error:getTypesInCon: forallT not supported" + + +-- returns the undividable types contained in given type. Like removing all +-- AppTs and collecting the single types in a list. +getBaseTypes :: Type -> [Type] +getBaseTypes (ForallT _ _ t) = + error "Error:getBaseTypes: forallT not supported" +getBaseTypes (AppT t1 t2) = getBaseTypes t1 ++ getBaseTypes t2 +getBaseTypes ListT = [ConT ''[]] +getBaseTypes (TupleT _) = [ConT ''(,)] +getBaseTypes ArrowT = error ("Error:getBaseTypes: ArrowT not supported" ++ + "have you tried to use functions as keys?") +getBaseTypes t = [t] + +getNameFromBndr :: TyVarBndr -> Name +getNameFromBndr (PlainTV name) = name +getNameFromBndr (KindedTV name _) = name + +-- generates the KeyMap-instance-declaration for given key and trie +genKeyMapInstanceDec :: [Dec] -> [(Type,Type)] -> Dec -> Dec -> Q [Dec] +genKeyMapInstanceDec knownDecs key2trie trieDec keyDec = do + --trace ("instance: " ++ pprint trieDec) (return ()) + -- let trie2key = map (\ (a,b) -> (b,a)) key2trie + g_empty <- gen_empty knownDecs trieDec + g_null <- gen_null knownDecs trieDec + g_lookup <- gen_lookup knownDecs keyDec trieDec + g_alter <- gen_alter knownDecs keyDec trieDec + g_combine <- gen_combine knownDecs keyDec trieDec + g_mapMaybeWithKey <- gen_mapMaybeWithKey knownDecs keyDec trieDec + g_toList <- gen_toList knownDecs keyDec trieDec + let methods = [ g_empty + , g_null + , g_lookup + , g_alter + , g_combine + , g_mapMaybeWithKey + , g_toList + ] + + case trieDec of + DataD _ triename tvarbndrs _ _ -> do + let tvarnames = map getNameFromBndr tvarbndrs + return (mkKeyMapInstanceDec key2trie triename tvarnames methods) + NewtypeD _ triename tvarbndrs _ _ -> do + let tvarnames = map getNameFromBndr tvarbndrs + return (mkKeyMapInstanceDec key2trie triename tvarnames methods) + _ -> return [] +-- builds the instance declaration +mkKeyMapInstanceDec :: [(Type,Type)] -> Name -> [Name] -> [Dec] -> [Dec] +mkKeyMapInstanceDec key2trie triename tvarnames methods = + let trie2key = map (\ (a,b) -> (b,a)) key2trie + tvarnamesWithoutVal = take (length tvarnames - 1) tvarnames + keyMapCxt = map (mkKeyMapCxt trie2key) tvarnamesWithoutVal + keyType = mkKeyType trie2key tvarnamesWithoutVal triename + trieType = mkTrieType key2trie keyType + keyMapType = AppT (AppT (ConT ''KeyMap) keyType) trieType + in [InstanceD keyMapCxt keyMapType methods] + +-- builds the context of the KeyMap-instance-declaration for a given type +-- variable +mkKeyMapCxt :: [(Type,Type)] -> Name -> Pred +mkKeyMapCxt trie2key tvarname = + let keytvar = fromJust (lookup (VarT tvarname) trie2key) + in ClassP ''KeyMap [keytvar, VarT tvarname] + +-- builds the key type needed for the KeyMap-instance-declaration +-- variable +mkKeyType :: [(Type,Type)] -> [Name] -> Name -> Type +mkKeyType trie2key tvarnames triename = + let keytvars = map (fromJust . ((flip lookup) trie2key) . VarT) tvarnames + keyTypeCon = fromJust (lookup (ConT triename) trie2key) + in foldl AppT keyTypeCon keytvars + +-- builds the trie type needed for the KeyMap-instance-declaration +-- variable +mkTrieType :: [(Type,Type)] -> Type -> Type +mkTrieType key2trie keyType = + replaceKeyByTrie key2trie keyType + +-- generates the empty-method of KeyMap +gen_empty :: [Dec] -> Dec -> Q Dec +gen_empty knownDecs (NewtypeD _ _ _ con _) = do + let dataconE = conE (getNameOfCon con) + funD (mkName "empty") [clause [] (normalB [| $dataconE KeyMap.empty|]) []] +gen_empty knownDecs trieDec@(DataD _ _ _ _ _) = do + noTrieCon <- getNoTrieCon knownDecs trieDec + funD (mkName "empty") + [clause [] (normalB (conE (getNameOfCon noTrieCon))) []] + + +-- generates the null-method of KeyMap +gen_null :: [Dec] -> Dec -> Q Dec +gen_null knownDecs (NewtypeD _ _ _ con _) = do + (triepat,[varname]) <- mkConPattern con + let m = varE varname + funD (mkName "null") [clause [triepat] (normalB [| KeyMap.null ($m)|]) []] +gen_null knownDecs triedec@(DataD _ _ _ _ _) = do + (emptyTrieConPattern,_) <- + getNoTrieCon knownDecs triedec >>= mkConPattern + (nonEmptyTrieConPattern,nonEmptyTrieVarNames) <- + getNonEmptyTrieCon knownDecs triedec >>= mkConNullPattern knownDecs + funD (mkName "null") + [clause [emptyTrieConPattern] (normalB (conE 'True)) [], + clause [nonEmptyTrieConPattern] + (nullBody knownDecs triedec nonEmptyTrieVarNames) [], + clause [wildP] (normalB (conE 'False)) []] + + where mkConNullPattern :: [Dec] -> Con -> Q (PatQ,[Name]) + mkConNullPattern knownDecs con = do + let types = getTypesInCon con + patternWithNames <- mapM (getNullPatternForType knownDecs) types + return (conP (getNameOfCon con) (map fst patternWithNames), + concatMap snd patternWithNames) + + getNullPatternForType :: [Dec] ->Type -> Q (PatQ,[Name]) + getNullPatternForType knownDecs t = do + let ot = getOutermostTypeOfType t + mdec = find ((== (getNameOfType ot)).getNameOfDec) knownDecs + if isJust mdec + then do + let dec = fromJust mdec + if isNewtypeD (fromJust mdec) + then do [con] <- getConstrsOfDataDec knownDecs dec + varname <- newName "m" + return (conP (getNameOfCon con) [varP varname], + [varname]) + else do con <- getNoTrieCon knownDecs (fromJust mdec) + return (conP (getNameOfCon con) [],[]) + else do let conName = getNameOfType ot + if (conName == ''Maybe) + then do return (conP 'Nothing [],[]) + else do vname <- newName "x" + return (varP vname,[vname]) + + nullBody :: [Dec] -> Dec -> [Name] -> BodyQ + nullBody _ _ [] = normalB (conE 'True) -- for noTrieCon + nullBody knownDecs triedec names = do + con <- getNonEmptyTrieCon knownDecs triedec + let types = getTypesInCon con + normalB (appE (varE 'and) + (listE (zipWith appE + (map (const (varE 'KeyMap.null)) types) + (map varE names)))) + + + +getNameOfType :: Type -> Name +getNameOfType (VarT name) = name +getNameOfType (ConT name) = name +getNameOfType t = error ("Error: getNameOfType: " ++ show t ++ "has no name") + +-- returns the data constructors of the given declaration. If the declaration +-- is one of a type synonym, the constructors of the underlying data type are +-- returned +getConstrsOfDataDec :: [Dec] -> Dec -> Q [Con] +getConstrsOfDataDec knownDecs dec = + case dec of + DataD _ _ _ cons _ -> return cons + NewtypeD _ _ _ con _ -> return [con] + TySynD name _ t -> do + let (ConT newname) = getOutermostTypeOfType t + tdec <- doReify knownDecs newname + getConstrsOfDataDec knownDecs tdec + _ -> error "Error:getConstrsOfDataDec: not implemented!" + where doReify :: [Dec] -> Name -> Q Dec + doReify knownDecs name = do + let knownDec = find ((==name).getNameOfDec) knownDecs + if isJust knownDec + then return (fromJust knownDec) + else do + info <- reify name + case info of + TyConI tdec -> return tdec + _ -> error "doReify: TyConI expected" + +getOutermostTypeOfType :: Type -> Type +getOutermostTypeOfType (AppT t1 t2) = getOutermostTypeOfType t1 +getOutermostTypeOfType t = t + +-- returns the constructor for the empty trie +-- Assumption: a trie has two cons and the first of them is the one for the +-- empty trie +getNoTrieCon :: [Dec] -> Dec -> Q Con +getNoTrieCon knownDecs triedec = do + cons <- getConstrsOfDataDec knownDecs triedec + return (head cons) + +-- returns the constructor for the nonempty trie +-- Assumption: a trie has two cons and the first of them is the one for the +-- empty trie +getNonEmptyTrieCon :: [Dec] -> Dec -> Q Con +getNonEmptyTrieCon knownDecs dec = do + cons <-getConstrsOfDataDec knownDecs dec + return (cons !! 1) + +-- generates the lookup-method of KeyMap +gen_lookup :: [Dec] -> Dec -> Dec -> Q Dec +gen_lookup knownDecs (NewtypeD _ _ _ keycon _) (NewtypeD _ _ _ triecon _) = do + (triepat,[trievarname]) <- mkConPattern triecon + (keypat,[keyvarname]) <- mkConPattern keycon + let m = varE trievarname + k = varE keyvarname + funD (mkName "lookup") [clause [keypat,triepat] + (normalB [| KeyMap.lookup $k $m|]) + []] + +gen_lookup knownDecs keyDec (NewtypeD _ _ _ triecon _) = do + (triepat,[trievarname]) <- mkConPattern triecon + keyvarname <- newName "k" + let m = varE trievarname + k = varE keyvarname + funD (mkName "lookup") [clause [varP keyvarname,triepat] + (normalB [| KeyMap.lookup $k $m|]) + []] +gen_lookup knownDecs keyDec trieDec@(DataD _ _ _ _ _) = do + noTrieCon <- getNoTrieCon knownDecs trieDec + nonEmptyTrieCon <- getNonEmptyTrieCon knownDecs trieDec + keyCons <- getConstrsOfDataDec knownDecs keyDec + + emptyTrieClause <- gen_lookupClause noTrieCon Nothing + nonEmptyTrieClauses <- + mapM (gen_lookupClause nonEmptyTrieCon) + (map Just (zip keyCons + [0..])) + return (FunD (mkName "lookup") (emptyTrieClause : nonEmptyTrieClauses)) + + +-- generates a clause for the lookup-method of KeyMap +-- (con,n) = key's nth data con => recursively call lookup on nth field of +-- nonempty triecon +gen_lookupClause :: Con -> Maybe (Con,Int) -> Q Clause +gen_lookupClause trieCon@(NormalC triename _) mkeyCon = do + case mkeyCon of + Nothing -> -- triecon is con for empty trie,no key pattern needed + clause [wildP, conP triename []] (normalB (conE 'Nothing)) [] + Just (keyCon,n) -> do + (keyPat,keyVarNames) <- mkConPattern keyCon + (triePat,trieVarNames) <- mkConPattern trieCon + let k = length keyVarNames + clause [keyPat,triePat] + (normalB (apply (varE (mkName ("lookup" ++ show k))) + (map varE keyVarNames ++ + [varE (trieVarNames !! n)]))) + [] +gen_lookupClause tc _ = + error ("Error:gen_lookupClause: malformed trie constructor: " ++ show tc) + + +-- returns a pattern for the given con and a list of the names of the variables +-- for the pattern's fields +mkConPattern :: Con -> Q (PatQ,[Name]) +mkConPattern (NormalC name types) = do + varPNames <- mapM newName (map (const "x") types) + return (conP name (map varP varPNames),varPNames) +mkConPattern (RecC name types) = do + varPNames <- mapM newName (map (const "x") types) + return (conP name (map varP varPNames),varPNames) +mkConPattern (InfixC t1 name t2) = do + let types = [t1,t2] + [varPName1,varPName2] <- mapM newName (map (const "x") types) + return (infixP (varP varPName1) name (varP varPName2),[varPName1,varPName2]) +mkConPattern (ForallC _ _ _) = + error "Error:mkKeyPattern: ForallC not supported!" + + + -- generates the alter-method of KeyMap +gen_alter :: [Dec] -> Dec -> Dec -> Q Dec +gen_alter knownDecs (NewtypeD _ _ _ keycon _) (NewtypeD _ _ _ triecon _) = do + (triepat,[trievarname]) <- mkConPattern triecon + (keypat,[keyvarname]) <- mkConPattern keycon + fvarname <-newName "f" + let m = varE trievarname + f = varE fvarname + k = varE keyvarname + c = conE (getNameOfCon triecon) + funD (mkName "alter") + [clause [keypat,varP fvarname,triepat] + (normalB [| $c (KeyMap.alter $k $f $m)|]) + []] + +gen_alter knownDecs keyDec (NewtypeD _ _ _ con _) = do + (triepat,[trievarname]) <- mkConPattern con + fvarname <-newName "f" + keyvarname <- newName "k" + let m = varE trievarname + f = varE fvarname + k = varE keyvarname + c = conE (getNameOfCon con) + funD (mkName "alter") + [clause [varP keyvarname,varP fvarname,triepat] + (normalB [| $c (KeyMap.alter $k $f $m)|]) + []] +gen_alter knownDecs keyDec trieDec@(DataD _ _ _ _ _) = do + noTrieCon <- getNoTrieCon knownDecs trieDec + nonEmptyTrieCon <- getNonEmptyTrieCon knownDecs trieDec + keyCons <- getConstrsOfDataDec knownDecs keyDec + + emptyTrieClauses <- mapM (gen_alterClause knownDecs trieDec noTrieCon) + (zip keyCons [0..]) + nonEmptyTrieClauses <- + mapM (gen_alterClause knownDecs trieDec nonEmptyTrieCon) + (zip keyCons [0..]) + return (FunD (mkName "alter") (emptyTrieClauses ++ nonEmptyTrieClauses)) + +-- generates a clause for the alter-method of KeyMap +-- (con,n) = key's nth data con +gen_alterClause :: [Dec] -> Dec -> Con -> (Con,Int) -> Q Clause +gen_alterClause knownDecs trieDec trieCon@(NormalC triename _) (keyCon,n) = + --trace ("genalterclause: " ++ show keyCon ++ "\n" ++ show trieCon) $ + do + nonEmptyTrieCon <- getNonEmptyTrieCon knownDecs trieDec + (keyPat,keyVarNames) <- mkConPattern keyCon + (triePat,trieVarNames) <- mkConPattern trieCon + fVarName <- newName "f" + + let emptyTrieFields = mkEmptyTrieFields nonEmptyTrieCon + oldFields = if trieVarNames == [] + then map return emptyTrieFields + else map varE trieVarNames + fieldToChange = oldFields !! n + newField = apply (varE (mkName ("alter" ++ show (length keyVarNames)))) + (map varE keyVarNames ++ [varE fVarName,fieldToChange]) + clause [keyPat,varP fVarName,triePat] + (normalB (appE (varE 'tidy) + (apply (conE (getConName nonEmptyTrieCon)) + (take n oldFields ++ + (newField : drop (n+1) oldFields))))) + [] +gen_alterClause _ _ _ _ = + error "Error:gen_alterClause: malformed trie constructor!" + + +getConName :: Con -> Name +getConName (NormalC name _) = name +getConName (RecC name _) = name +getConName (InfixC _ name _) = name +getConName _ = error "Error: getConName:Forall not supported" + +-- builds default fields for the nonempty triecon +mkEmptyTrieFields :: Con -> [Exp] +mkEmptyTrieFields trieCon = + map type2empty (getTypesInCon trieCon) + where type2empty :: Type -> Exp + type2empty (AppT t _) + | t == ConT ''Maybe = ConE 'Nothing + | otherwise = VarE 'KeyMap.empty + type2empty _ = VarE 'KeyMap.empty + + +-- generates the combine-method for KeyMap +gen_combine :: [Dec] -> Dec -> Dec -> Q Dec +gen_combine knownDecs keyDec (NewtypeD _ _ _ con _) = do + (triepat1,[trievarname1]) <- mkConPattern con + (triepat2,[trievarname2]) <- mkConPattern con + fname <- newName "f" + let m1 = varE trievarname1 + m2 = varE trievarname2 + f = varE fname + c = conE (getNameOfCon con) + funD (mkName "combine") + [clause [varP fname, triepat1,triepat2] + (normalB [| $c (KeyMap.combine $f $m1 $m2)|]) + []] +gen_combine knownDecs keyDec trieDec@(DataD _ _ _ _ _) = do + fName <- newName "f" + ns <- getNs keyDec + noTrieConName <- getNoTrieCon knownDecs trieDec >>= (return . getConName) + nonEmptyTrieCon <- getNonEmptyTrieCon knownDecs trieDec + let nonEmptyTrieConFields = mkEmptyTrieFields nonEmptyTrieCon + + nonEmptyTrieConName = getConName nonEmptyTrieCon + -- emptyTrie = apply (conE nonEmptyTrieConName) + -- (map return nonEmptyTrieConFields) + noTrieConP = conP noTrieConName [] + (nonEmptyTrieConP1,nonEmptyTrieConNames1) <- mkConPattern nonEmptyTrieCon + (nonEmptyTrieConP2,nonEmptyTrieConNames2) <- mkConPattern nonEmptyTrieCon + --combinenDecs <- mapM combinenD ns + + emptyEmptyClause <- clause [wildP,noTrieConP,noTrieConP] + (normalB (conE noTrieConName)) + [] + emptyNonEmptyClause <- + clause [varP fName,noTrieConP,nonEmptyTrieConP2] + (normalB (appE (varE 'tidy) + (apply (conE nonEmptyTrieConName) + (map (combineField (varE fName)) + (zip3 ns + (map return + nonEmptyTrieConFields) + (map varE + nonEmptyTrieConNames2))) + ))) + [] + nonEmptyEmptyClause <- + clause [varP fName,nonEmptyTrieConP1,noTrieConP] + (normalB (appE (varE 'tidy) + (apply (conE nonEmptyTrieConName) + (map (combineField (varE fName)) + (zip3 ns + (map varE nonEmptyTrieConNames1) + (map return nonEmptyTrieConFields) + ))))) + [] + nonEmptyNonEmptyClause <- + clause [varP fName,nonEmptyTrieConP1,nonEmptyTrieConP2] + (normalB (appE (varE 'tidy) + (apply (conE nonEmptyTrieConName) + (map (combineField (varE fName)) + (zip3 ns + (map varE nonEmptyTrieConNames1) + (map varE nonEmptyTrieConNames2)) + )))) + [] + + return (FunD (mkName "combine") [emptyEmptyClause,emptyNonEmptyClause, + nonEmptyEmptyClause,nonEmptyNonEmptyClause]) + where combineField :: ExpQ -> (Int,ExpQ,ExpQ) -> ExpQ + combineField f (0,a,b) = apply (varE (mkName "combine0")) [f,a,b] + combineField f (n,a,b) = + {- appE (varE 'ensureTrie) + (apply (varE (mkName ("combine"++show n))) + [f,appE (varE 'trieToMaybe) a, + appE (varE 'trieToMaybe) b])-} + apply (varE (mkName ("combine"++show n))) [f, a, b] + +gen_mapMaybeWithKey :: [Dec] -> Dec -> Dec -> Q Dec +gen_mapMaybeWithKey knownDecs (NewtypeD _ _ _ keycon _) + (NewtypeD _ _ _ triecon _) = do + (triepat,[trievarname]) <- mkConPattern triecon + fvarname <-newName "f" + let m = varE trievarname + f = varE fvarname + c = conE (getNameOfCon triecon) + funD (mkName "mapMaybeWithKey") + [clause [varP fvarname,triepat] + (normalB [| $c (KeyMap.mapMaybeWithKey $f $m)|]) + []] + +gen_mapMaybeWithKey knownDecs keyDec (NewtypeD _ _ _ con _) = do + (triepat,[trievarname]) <- mkConPattern con + fvarname <-newName "f" + let m = varE trievarname + f = varE fvarname + c = conE (getNameOfCon con) + funD (mkName "mapMaybeWithKey") + [clause [varP fvarname,triepat] + (normalB [| $c (KeyMap.mapMaybeWithKey $f $m)|]) + []] +gen_mapMaybeWithKey knownDecs keyDec trieDec@(DataD _ _ _ _ _) = do + noTrieCon <- getNoTrieCon knownDecs trieDec + let noTrieName = getNameOfCon noTrieCon + nonEmptyTrieCon <- getNonEmptyTrieCon knownDecs trieDec + fvarname <-newName "f" + + emptyTrieClause <- clause [varP fvarname, conP noTrieName []] + (normalB $ conE noTrieName) [] + nonEmptyTrieClause <- + gen_mapMaybeWithKeyClause knownDecs keyDec trieDec nonEmptyTrieCon + return (FunD (mkName "mapMaybeWithKey") + [emptyTrieClause, nonEmptyTrieClause]) + +gen_mapMaybeWithKeyClause :: [Dec] -> Dec -> Dec -> Con -> Q Clause +gen_mapMaybeWithKeyClause knownDecs keyDec trieDec trieCon@(NormalC triename _) = + do + nonEmptyTrieCon <- getNonEmptyTrieCon knownDecs trieDec + (triePat,trieVarNames) <- mkConPattern trieCon + fVarName <- newName "f" + ns <- getNs keyDec + cons <- getConstrsOfDataDec knownDecs keyDec + + let oldFields = map varE trieVarNames + newFields = zipWith3 (\ n con o -> apply (varE + (mkName $ + "mapMaybeWithKey" ++ show n)) + [conE $ getNameOfCon con, o, + varE fVarName]) + ns cons oldFields + clause [varP fVarName,triePat] + (normalB (appE (varE 'tidy) + (apply (conE (getConName nonEmptyTrieCon)) newFields))) + [] +gen_mapMaybeWithKeyClause _ _ _ _ = + error "Error:gen_mapMaybeWithKeyClause: malformed trie constructor!" + +{- +nth :: String -> Int -> [a] -> a +nth descr n list = --trace ("nth " ++ show n ++ " " ++ descr ++ "\n") + (nth' descr n list) + +nth' :: String -> Int -> [a] -> a +nth' d _ [] = error (d ++ ": nth: Index to large!") +nth' _ 0 (x:_) = x +nth' d n (_:xs) = nth' d (n-1) xs + +fromJust' :: String -> Maybe a -> a +fromJust' d Nothing = error d +fromJust' _ (Just a) = a + +reify' :: String -> Name -> Q Info +reify' str name = do + --trace (str++ " " ++ nameBase name) (return ()) + reify name + +-} +getNameOfDec :: Dec -> Name +getNameOfDec (FunD name _) = name +getNameOfDec (DataD _ name _ _ _) = name +getNameOfDec (NewtypeD _ name _ _ _) = name +getNameOfDec (TySynD name _ _) = name +getNameOfDec (ClassD _ name _ _ _) = name +getNameOfDec (SigD name _) = name +getNameOfDec dec = error ("getNameOfDec: " ++ show dec ++ " has no name!") + +-- equality test for decs, (==) is not suitable,because the same decs with +-- only different named variables are supposed to be different +eqDec :: Dec -> Dec -> Bool +eqDec (InstanceD _ t1 _) (InstanceD _ t2 _) = eqTypeIgnoreVarNames t1 t2 +eqDec (InstanceD _ t1 _) d2 = False +eqDec d1 (InstanceD _ t1 _) = False +eqDec d1 d2 = getNameOfDec d1 == getNameOfDec d2 + +-- equality test for Types, (==) is not suitable,because the same Types with +-- only different named variables are supposed to be different +eqTypeIgnoreVarNames :: Type -> Type -> Bool +eqTypeIgnoreVarNames (AppT t1 t2) (AppT t1' t2') = + eqTypeIgnoreVarNames t1 t1' && eqTypeIgnoreVarNames t2 t2' +eqTypeIgnoreVarNames (ForallT names cxt t) (ForallT names' cxt' t') = + eqTypeIgnoreVarNames t t' -- for use here, this is sufficient +eqTypeIgnoreVarNames (VarT _) (VarT _) = True +eqTypeIgnoreVarNames t1 t2 = t1 == t2 + +getNameOfCon :: Con -> Name +getNameOfCon (NormalC name _) = name +getNameOfCon (RecC name _) = name +getNameOfCon (InfixC _ name _) = name +getNameOfCon (ForallC _ _ con) = getNameOfCon con + +-- makes expression, where f is applied to args +apply :: ExpQ -> [ExpQ] -> ExpQ +apply f args = foldl appE f args + + +applyTypesAcc :: [Type] -> Type -> Type +applyTypesAcc [] acc = acc +applyTypesAcc (t:ts) acc = applyTypesAcc ts (AppT t acc) + +-- when building fields of trie, one needs to add the val - variable +-- this is done by this helper function +addVal :: [Type] -> Type -> [Type] +addVal [] valtype = [AppT (ConT ''Maybe) valtype] +addVal [t] valtype = [AppT t valtype] +addVal (t:ts) valtype = t : addVal ts valtype + + + +-- this function lifts the type (map val -> map val) to +-- (Maybe (map val) -> Maybe (map val)) +-- for use with alter-continuation +lift1 :: KeyMap key map + => (map val -> map val) -> Maybe (map val) -> Maybe (map val) +lift1 f = trieToMaybe . f . maybe KeyMap.empty id + + +-- this function lifts the type (map val -> map val' -> map val'') to +-- (Maybe (map val) -> Maybe (map val') -> Maybe (map val'')) +-- for use with combine +lift2 :: KeyMap key map + => (map val -> map val' -> map val'') + -> Maybe (map val) -> Maybe (map val') -> Maybe (map val'') +lift2 f mx my + = maybe (my >>= trieToMaybe . f KeyMap.empty) + (trieToMaybe . flip f (maybe KeyMap.empty id my)) + mx + + + +--tidym :: KeyMap key map => map val -> Maybe (map val) +--tidym t = if KeyMap.null t then Nothing else Just t + +tidy :: KeyMap key map => map val -> map val +tidy m = if KeyMap.null m then KeyMap.empty else m + +trieToMaybe :: KeyMap key map => map val -> Maybe (map val) +trieToMaybe t = if KeyMap.null t then Nothing else Just t + + + +ensureTrie :: KeyMap key map => Maybe (map val) -> map val +ensureTrie m = fromMaybe KeyMap.empty m + +maybe2trie :: ExpQ +maybe2trie = [| \ mt -> fromMaybe KeyMap.empty mt |] + + +-- generates the declaration for the helper-function lookup1,lookup2,.. +-- according to n +lookupnD :: Int -> DecQ +lookupnD 0 = do + let lookupName = mkName "lookup0" + (funD lookupName [clause [] (normalB (varE 'id)) []]) +lookupnD n = do + kvarNames <- mapM newName (replicate n "key") + mvarName <- newName "m" + tmpvarNames <- mapM newName (take (n-1) (repeat "x")) + let argNames = kvarNames ++ [mvarName] + args = map varP argNames + lookups = + map (\ (n1,n2,k) -> bindS (varP n2) (apply (varE 'KeyMap.lookup) + [varE k,varE n1])) + (zip3 (mvarName:tmpvarNames) tmpvarNames kvarNames) + lookupName = mkName ("lookup" ++ show n) + (funD lookupName + [clause args + (normalB (doE (lookups ++ + [noBindS (apply (varE 'KeyMap.lookup) + [varE (last kvarNames), + varE (last (mvarName:tmpvarNames))])]))) []]) + + +-- generates the declaration for the helper-function alter1,alter2,.. +-- according to n +alternD :: Int -> DecQ +alternD 0 = do + -- let alterName = mkName "alter0" + [alterDec] <- [d| alter0 = id |] + return alterDec +alternD 1 = do + [alterDec] <- [d| alter1 k f m = {-tidy-} (KeyMap.alter k f m) |] + return alterDec +alternD n = do + let alterName = mkName ("alter"++show n) + --alter1Name = mkName "alter1" + alternMinus1Name = mkName ("alter"++show (n-1)) + kvarNames <- mapM newName (replicate n "key") + mvarName <- newName "m" + fvarName <- newName "f" + let argNames = kvarNames ++ [fvarName,mvarName] + args = map varP argNames + kvars = map varE kvarNames + continuation = [| trieToMaybe . + $(apply (varE 'KeyMap.alter) + [last kvars,varE fvarName]) + . ensureTrie |] + (funD alterName + [clause args (normalB (apply (varE alternMinus1Name) + (take (n-1) kvars ++ + [continuation,varE mvarName]))) []]) + + +-- generates the declaration for the helper-function combine1,combine2,.. +-- according to n +combinenD :: Int -> Q [Dec] +combinenD 0 = + [d| combine0 :: (Maybe val -> Maybe val' -> Maybe val'') -> Maybe val -> Maybe val' -> Maybe val'';combine0 f = f |] + +combinenD 1 = do + [d| combine1 :: KeyMap key map => (Maybe val -> Maybe val' -> Maybe val'') -> (map val) -> (map val') -> (map val'');combine1 f ma mb = {-tidy-} (KeyMap.combine f ma mb) |] + +combinenD n = + do + let combineName = mkName ("combine"++show n) + valNames <- mapM newName (replicate 3 "val") + keyNames <- mapM newName (replicate n "key") + mapNames <- mapM newName (replicate n "map") + + fname <- newName "f" + maname <- newName "ma" + mbname <- newName "mb" + --trace ("valNames: " ++ show valNames) (return ()) + let context = map (\ (k,m) -> (ClassP ''KeyMap [k, m])) + (zip (map VarT keyNames) (map VarT mapNames)) + -- f = (Maybe val -> Maybe val' -> Maybe val'') + f = AppT (AppT ArrowT (AppT (ConT ''Maybe) (VarT (valNames!!0)))) + (AppT (AppT ArrowT (AppT (ConT ''Maybe) (VarT (valNames!!1)))) + (AppT (ConT ''Maybe) (VarT (valNames!!2)))) + args = map (mkArg mapNames) valNames + singleTypes = addVal (map (AppT ArrowT) (take 2 args)) (args!!2) + sigType = + AppT (AppT ArrowT f) + (applyTypesAcc (tail (reverse singleTypes)) (head (reverse singleTypes))) + sig = SigD combineName + (ForallT (map PlainTV $ keyNames ++ mapNames ++ valNames) context sigType) + [fvar,mavar,mbvar] = [varE fname,varE maname,varE mbname] + continuation = + [| \ ma mb -> trieToMaybe ($(varE 'KeyMap.combine) $fvar + (ensureTrie ma) + (ensureTrie mb))|] + def <- (funD combineName + [clause [varP fname,varP maname,varP mbname] + (normalB [| $(combinen (n-1)) $continuation $mavar + $mbvar|]) + []]) + return [sig,def] + where mkArg :: [Name] -> Name -> Type + mkArg mapNames valName = + let singleTypes = addVal (map VarT mapNames) (VarT valName) + in (applyTypesAcc (tail (reverse singleTypes)) + (head (reverse singleTypes))) + + +combinen :: Int -> ExpQ +combinen n = varE (mkName ("combine" ++ show n)) + +mapMaybeWithKeynD :: Int -> DecQ +mapMaybeWithKeynD 0 = do + [dec] <- [d| + mapMaybeWithKey0 _ Nothing _ = Nothing + mapMaybeWithKey0 k (Just v) f = f k v + |] + return dec +mapMaybeWithKeynD n = do + let fname = mkName $ "mapMaybeWithKey" ++ show n + kf <- newName "kf" + t <- newName "t" + f <- newName "f" + + let e = mapMaybeWithKeynD' n (varE t) (varE f) (varE kf) [] + + funD fname [clause [varP kf, varP t, varP f] (normalB e) []] + +mapMaybeWithKeynD' 1 t f kf ks = + [| KeyMap.mapMaybeWithKey (\ k v -> $f ($(apply kf $ reverse ks) k) v) $t + |] +mapMaybeWithKeynD' m t f kf ks = do + k <- newName "k" + v <- newName "v" + let kp = varP k + ke = varE k + vp = varP v + ve = varE v + + apply [| KeyMap.mapMaybeWithKey |] + [lamE [kp, vp] $ appE [| Just |] $ + mapMaybeWithKeynD' (m - 1) ve f kf $ ke : ks, t] + + +{- + [| (\ k $vp -> Just $ $(mapMaybeWithKeynD (m - 1) $v $f $kf)) + |] +-} + +-- generates the toList-method of KeyMap +gen_toList :: [Dec] -> Dec -> Dec -> Q Dec +gen_toList knownDecs keyDec (NewtypeD _ _ _ con _) = do + (triepat,[trievarname]) <- mkConPattern con + let m = varE trievarname + funD (mkName "toList") [clause [triepat] (normalB [| KeyMap.toList $m|]) []] +gen_toList knownDecs keyDec trieDec@(DataD _ _ _ _ _) = do + noTrieCon <- getNoTrieCon knownDecs trieDec + nonEmptyTrieCon <- getNonEmptyTrieCon knownDecs trieDec + ns <- getNs keyDec + emptyTrieClause <- clause [conP (getNameOfCon noTrieCon) []] + (normalB (conE '[])) [] + nonEmptyTrieClause <- gen_toListClause nonEmptyTrieCon keyDec + return (FunD (mkName "toList") [emptyTrieClause,nonEmptyTrieClause]) + + +gen_toListClause :: Con -> Dec -> Q Clause +gen_toListClause trieCon@(NormalC triename _) keyDec = do + (triePat,trieVarNames) <- mkConPattern trieCon + ns <- getNs keyDec + let toLists = map (varE . mkName . ("toList"++) . show) ns + recCalls = zipWith appE toLists (map varE trieVarNames) + + clause [triePat] + (normalB (foldr appE + (last recCalls) + (init (map (appE (varE '(++))) recCalls)))) + [] +gen_toListClause tc _ = + error ("Error:gen_toListClause: malformed trie constructor: " ++ show tc) + +{- +toListn2 :: (KeyMap ak am, KeyMap bk bm) => (am (bm val)) -> [val] +toListn2 m = concatMap KeyMap.toList (KeyMap.toList m) + +toListn3 m = concatMap KeyMap.toList (concatMap KeyMap.toList (KeyMap.toList m)) +-} +-- generates the declaration for the helper-function toList1,toList2,.. +-- according to n +toListnD :: Int -> DecQ +toListnD 0 = do [toList0Dec] <- [d| toList0 = maybe [] (\mx -> [mx]) |] + return toList0Dec +toListnD 1 = do [toList1Dec] <- [d| toList1 m = KeyMap.toList m |] + return toList1Dec + +toListnD n = do + mName <- newName "m" + let toListName = mkName ("toList" ++ show n) + args = [varP mName] + concatMaps = replicate (n-1) (appE (varE 'concatMap) + (varE 'KeyMap.toList)) + body = normalB (foldr appE + (appE (varE (mkName "toList1")) (varE mName)) + concatMaps) + funDec <- funD toListName [clause args body []] + return funDec + + + +isNewtypeD :: Dec -> Bool +isNewtypeD (NewtypeD _ _ _ _ _) = True +isNewtypeD _ = False + + diff --git a/src/Data/KeyMap.hs b/src/Data/KeyMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyMap.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE + FlexibleInstances, + FunctionalDependencies, + MultiParamTypeClasses + #-} +-- This module uses multi-parameter type-classes with functional dependencies. +-- Associated types would allow for a more readable implementation. + +module Data.KeyMap ( + + KeyMap, empty, null, lookup, alter, combine, toList, + + insert, adjust, delete, + + unionWith, union, symDiff, + + updateWith, difference, update, + + intersectionWith, intersection, + + map, mapMaybeWithKey, + + fromList + + ) where + +import Prelude hiding ( null, lookup, map ) +import qualified Data.Map as M +import qualified Data.IntMap as IM + +just :: a -> Maybe a +just = (Just $!) + +-- The dependency "key -> map" is not necessary albeit convenient. +class KeyMap key map | map -> key where + empty :: map val + null :: map val -> Bool + lookup :: key -> map val -> Maybe val + alter :: key -> (Maybe val -> Maybe val) -> map val -> map val + combine :: (Maybe val -> Maybe val' -> Maybe val'') + -> map val -> map val' -> map val'' + mapMaybeWithKey :: (key -> val -> Maybe val') -> map val -> map val' + --combine = error "combine not implemented" + toList :: map val -> [val] + toList = error "toList not implemented" + +insert :: KeyMap key map => key -> val -> map val -> map val +insert key = alter key . const . just + +adjust :: KeyMap key map => key -> (val -> val) -> map val -> map val +adjust key alt = alter key (>>=just.alt) + +delete :: KeyMap key map => key -> map val -> map val +delete key = alter key (const Nothing) + +unionWith :: KeyMap key map + => (val -> val -> Maybe val) -> map val -> map val -> map val +unionWith f + = combine (\mx my -> maybe my (\x -> maybe mx (\y -> f x y) my) mx) + +union :: KeyMap key map => map val -> map val -> map val +union = unionWith (\x _ -> just x) + +symDiff :: KeyMap key map => map val -> map val -> map val +symDiff = unionWith (\_ _ -> Nothing) + +updateWith :: KeyMap key map + => (val -> val' -> Maybe val) -> map val -> map val' -> map val +updateWith f + = combine (\mx my -> mx >>= \x -> maybe mx (\y -> f x y) my) + +difference :: KeyMap key map => map val -> map val' -> map val +difference = updateWith (\_ _ -> Nothing) + +update :: KeyMap key map => map val -> map val -> map val +update = updateWith (\_ y -> just y) + +intersectionWith :: KeyMap key map + => (val -> val' -> Maybe val'') + -> map val -> map val' -> map val'' +intersectionWith f = combine (\mx my -> mx >>= \x -> my >>= \y -> f x y) + +intersection :: KeyMap key map => map val -> map val -> map val +intersection = intersectionWith (\x _ -> just x) + +map :: KeyMap key map => (val -> val') -> map val -> map val' +map f = mapMaybeWithKey (\ _ -> Just . f) + +fromList :: KeyMap key map => [(key,val)] -> map val +fromList = foldr (uncurry insert) empty + + +instance Ord key => KeyMap key (M.Map key) where + empty = M.empty + null = M.null + lookup = M.lookup + alter = flip M.alter -- Data.Map.alter not supported in ghc 6.4 ?? + +-- alter key alt m +-- = maybe (maybe m (flip (M.insert key) m) (alt Nothing)) +-- (\_ -> M.update (alt.Just) key m) +-- (M.lookup key m) + + combine cmb m1 m2 + = M.fromAscList $ cmbAscLists cmb (M.toAscList m1) (M.toAscList m2) + + mapMaybeWithKey = M.mapMaybeWithKey + + toList = M.elems + + +cmbAscLists :: Ord key + => (Maybe val -> Maybe val' -> Maybe val'') + -> [(key,val)] -> [(key,val')] -> [(key,val'')] +cmbAscLists _ [] [] = [] +cmbAscLists cmb [] ((k,v):kvs) + = maybe (cmbAscLists cmb [] kvs) + (\w -> (k,w) : cmbAscLists cmb [] kvs) + (cmb Nothing (Just v)) +cmbAscLists cmb kvs@(_:_) [] = cmbAscLists (flip cmb) [] kvs +cmbAscLists cmb kv1@((k1,v1):kvs1) kv2@((k2,v2):kvs2) + | k1 < k2 + = maybe (cmbAscLists cmb kvs1 kv2) + (\v -> (k1,v) : cmbAscLists cmb kvs1 kv2) + (cmb (Just v1) Nothing) + | k1 > k2 + = maybe (cmbAscLists cmb kv1 kvs2) + (\v -> (k2,v) : cmbAscLists cmb kv1 kvs2) + (cmb Nothing (Just v2)) + | otherwise -- k1 == k2 + = maybe (cmbAscLists cmb kvs1 kvs2) + (\v -> (k1,v) : cmbAscLists cmb kvs1 kvs2) + (cmb (Just v1) (Just v2)) + + + +instance KeyMap Int IM.IntMap where + empty = IM.empty + null = IM.null + lookup = IM.lookup + alter = flip IM.alter -- Data.Map.alter not supported in ghc 6.4 ?? + +-- alter key alt m +-- = maybe (maybe m (flip (M.insert key) m) (alt Nothing)) +-- (\_ -> M.update (alt.Just) key m) +-- (M.lookup key m) + + mapMaybeWithKey = IM.mapMaybeWithKey + + combine cmb m1 m2 = + IM.fromAscList $ cmbAscLists cmb (IM.toAscList m1) (IM.toAscList m2) + + toList = IM.elems