uhc-util 0.1.6.0 → 0.1.6.2

raw patch · 13 files changed

+403/−78 lines, 13 filesdep −ListLikedep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: ListLike

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• src/UHC/Util/CompileRun.hs +9/−8
• src/UHC/Util/CompileRun2.hs +15/−16
• src/UHC/Util/CompileRun3.hs +11/−10
• src/UHC/Util/DependencyGraph.hs +1/−1
• src/UHC/Util/Error.hs +57/−0
• src/UHC/Util/FPath.hs +53/−7
• src/UHC/Util/FastSeq.hs +1/−1
• src/UHC/Util/Pretty.hs +8/−1
• src/UHC/Util/ScopeMapGam.hs +6/−6
• src/UHC/Util/Serialize.hs +97/−11
• src/UHC/Util/Utils.hs +137/−10
• src/UHC/Util/VarMp.hs +5/−4
• uhc-util.cabal +3/−3

@@ -48,7 +48,8 @@ import           System.Exit import           Control.Monad import           Control.Applicative(Applicative(..))-import           Control.Monad.Error as ME+import           UHC.Util.Error as ME+-- import           Control.Monad.Error as ME import           Control.Monad.State import           System.IO import qualified Data.Map as Map@@ -489,13 +490,13 @@   :: ( Ord n      , FPATH n, FileLocatable u loc, Show loc      , CompileUnitState s,CompileRunError e p,CompileUnit u n loc s,CompileModName n,CompileRunStateInfo i n p-     ) => (loc -> n -> FPath -> [(loc,FPath,[e])])		-- ^ get the locations for a name, possibly with errors-       -> ((FPath,loc,[e]) -> res)						-- ^ construct a result given a found location-       -> Bool											-- ^ stop when first is found-       -> [(FileSuffix,s)]								-- ^ suffix info-       -> [loc]											-- ^ locations to search-       -> Maybe n										-- ^ possibly a module name-       -> Maybe FPath									-- ^ possibly a file path+     ) => (loc -> n -> FPath -> [(loc,FPath,[e])])      -- ^ get the locations for a name, possibly with errors+       -> ((FPath,loc,[e]) -> res)                      -- ^ construct a result given a found location+       -> Bool                                          -- ^ stop when first is found+       -> [(FileSuffix,s)]                              -- ^ suffix info+       -> [loc]                                         -- ^ locations to search+       -> Maybe n                                       -- ^ possibly a module name+       -> Maybe FPath                                   -- ^ possibly a file path        -> CompilePhase n u i e [res] cpFindFilesForFPathInLocations getfp putres stopAtFirst suffs locs mbModNm mbFp   = do { cr <- get

@@ -56,7 +56,8 @@ import           Control.Monad import           Control.Monad.Fix import           Control.Applicative(Applicative(..))-import           Control.Monad.Error as ME+import           UHC.Util.Error as ME+-- import           Control.Monad.Error as ME import           Control.Monad.State import qualified Control.Exception as CE import           Control.Monad.Identity@@ -429,13 +430,13 @@   :: ( Ord n      , FPATH n, FileLocatable u loc, Show loc      , CompileRunner s n p loc u i e m-     ) => (loc -> n -> FPath -> [(loc,FPath,[e])])		-- ^ get the locations for a name, possibly with errors-       -> ((FPath,loc,[e]) -> res)						-- ^ construct a result given a found location-       -> Bool											-- ^ stop when first is found-       -> [(FileSuffix,s)]								-- ^ suffix info-       -> [loc]											-- ^ locations to search-       -> Maybe n										-- ^ possibly a module name-       -> Maybe FPath									-- ^ possibly a file path+     ) => (loc -> n -> FPath -> [(loc,FPath,[e])])      -- ^ get the locations for a name, possibly with errors+       -> ((FPath,loc,s,[e]) -> res)                        -- ^ construct a result given a found location+       -> Bool                                          -- ^ stop when first is found+       -> [(FileSuffixWith s)]                          -- ^ suffix info+       -> [loc]                                         -- ^ locations to search+       -> Maybe n                                       -- ^ possibly a module name+       -> Maybe FPath                                   -- ^ possibly a file path        -> CompilePhaseT n u i e m [res] cpFindFilesForFPathInLocations getfp putres stopAtFirst suffs locs mbModNm mbFp   = do { cr <- get@@ -444,19 +445,17 @@           then do { let fp = maybe (mkFPath $ panicJust ("cpFindFileForFPath") $ mbModNm) id mbFp                         modNm = maybe (mkCMNm $ fpathBase $ fp) id mbModNm                         suffs' = map fst suffs-                  ; fpsFound <- liftIO (searchLocationsForReadableFiles (\l f -> getfp l modNm f)-                                                                        stopAtFirst locs suffs' fp-                                       )+                  ; fpsFound <- liftIO $ searchLocationsForReadableFilesWith (\l f -> getfp l modNm f) stopAtFirst locs suffs fp                   ; case fpsFound of                       []                         -> do { cpSetErrs (creMkNotFoundErrL (crsiImportPosOfCUKey modNm (_crStateInfo cr)) (fpathToStr fp) (map show locs) suffs')                               ; return []                               }-                      ((_,_,e@(_:_)):_)+                      ((_,_,_,e@(_:_)):_)                         -> do { cpSetErrs e                               ; return []                               }-                      ffs@((ff,loc,_):_)+                      ffs@((ff,loc,s,_):_)                         -> do { cpUpdCU modNm (cuUpdLocation loc . cuUpdFPath ff . cuUpdState cus . cuUpdKey modNm)                               ; return (map putres ffs)                               }@@ -466,7 +465,7 @@                                                    Just c  -> c                                                    Nothing -> cusUnk                   }-          else return (maybe [] (\nm -> [putres (crCUFPath nm cr,crCULocation nm cr,[])]) mbModNm)+          else return (maybe [] (\nm -> [putres (crCUFPath nm cr, crCULocation nm cr, crCUState nm cr, [])]) mbModNm)        }  cpFindFilesForFPath@@ -474,9 +473,9 @@      ( Ord n      , FPATH n, FileLocatable u String      , CompileRunner s n p String u i e m-     ) => Bool -> [(FileSuffix,s)] -> [String] -> Maybe n -> Maybe FPath -> CompilePhaseT n u i e m [FPath]+     ) => Bool -> [FileSuffixWith s] -> [String] -> Maybe n -> Maybe FPath -> CompilePhaseT n u i e m [FPath] cpFindFilesForFPath-  = cpFindFilesForFPathInLocations (\l n f -> map (tup12to123 ([]::[e])) $ cpFindFileForNameOrFPath l n f) tup123to1+  = cpFindFilesForFPathInLocations (\l n f -> map (tup12to123 ([]::[e])) $ cpFindFileForNameOrFPath l n f) tup1234to1  cpFindFileForFPath   :: ( Ord n

@@ -59,7 +59,8 @@ import           Control.Monad import           Control.Monad.Fix import           Control.Applicative(Applicative(..))-import           Control.Monad.Error as ME+import           UHC.Util.Error as ME+-- import           Control.Monad.Error as ME import           Control.Monad.State import qualified Control.Exception as CE import           Control.Monad.Identity@@ -184,8 +185,8 @@  data CompileRun nm unit info err   = CompileRun-      { _crCUCache       :: Map.Map nm unit		-- cached compile units-      , _crNmForward     :: Map.Map nm nm		-- Forwarding mechanism for name changes+      { _crCUCache       :: Map.Map nm unit     -- cached compile units+      , _crNmForward     :: Map.Map nm nm       -- Forwarding mechanism for name changes       , _crCompileOrder  :: [[nm]]       , _crTopModNm      :: nm       , _crState         :: CompileRunState err@@ -474,13 +475,13 @@   :: ( Ord n, Show n      , FPATH n, FileLocatable u loc, Show loc      , CompileRunner s n p loc u i e m-     ) => (loc -> n -> FPath -> [(loc,FPath,[e])])		-- ^ get the locations for a name, possibly with errors-       -> ((FPath,loc,[e]) -> res)						-- ^ construct a result given a found location-       -> Bool											-- ^ stop when first is found-       -> [(FileSuffix,s)]								-- ^ suffix info-       -> [loc]											-- ^ locations to search-       -> Maybe n										-- ^ possibly a module name-       -> Maybe FPath									-- ^ possibly a file path+     ) => (loc -> n -> FPath -> [(loc,FPath,[e])])      -- ^ get the locations for a name, possibly with errors+       -> ((FPath,loc,[e]) -> res)                      -- ^ construct a result given a found location+       -> Bool                                          -- ^ stop when first is found+       -> [(FileSuffix,s)]                              -- ^ suffix info+       -> [loc]                                         -- ^ locations to search+       -> Maybe n                                       -- ^ possibly a module name+       -> Maybe FPath                                   -- ^ possibly a file path        -> CompilePhaseT n u i e m [res] cpFindFilesForFPathInLocations getfp putres stopAtFirst suffs locs mbModNm mbFp   = do { cr <- get

@@ -33,7 +33,7 @@   = DpdGr       { dgGr    :: Graph       , dgGrT   :: Graph-      , dgEdges	:: [(n, n, [n])]+      , dgEdges :: [(n, n, [n])]       , dgV2N   :: Vertex -> (n, [n])       , dgK2V   :: n -> Maybe Vertex       }

@@ -0,0 +1,57 @@+{-# LANGUAGE CPP, NoMonomorphismRestriction #-}++-- | Wrapper module around Control.Monad.Error, in order to be backwards compatible as far as UHC is concerned.++module UHC.Util.Error+  (+# if __GLASGOW_HASKELL__ >= 710+    module Control.Monad.Except+  -- , module Control.Monad.Error.Class+  , Error(..)+  , ErrorT+  +  , runErrorT +  , withErrorT+  , mapErrorT ++  , runError  +  , withError +  , mapError  +# else+    module Control.Monad.Error+# endif+  )+  where++#if __GLASGOW_HASKELL__ >= 710+import Control.Monad.Except+-- import Control.Monad.Error.Class (Error(..))+#else+import Control.Monad.Error+#endif++#if __GLASGOW_HASKELL__ >= 710+type ErrorT = ExceptT++runErrorT  = runExceptT+withErrorT = withExceptT+mapErrorT  = mapExceptT++runError  = runExcept+withError = withExcept+mapError  = mapExcept++-- | Copied/old/deprecated functionality from Control.Monad.Error.Class+class Error a where+    -- | Creates an exception without a message.+    -- The default implementation is @'strMsg' \"\"@.+    noMsg  :: a+    -- | Creates an exception with a message.+    -- The default implementation of @'strMsg' s@ is 'noMsg'.+    strMsg :: String -> a++    noMsg    = strMsg ""+    strMsg _ = noMsg++#else+#endif

@@ -30,11 +30,15 @@    -- * SearchPath   , SearchPath-  , FileSuffixes, FileSuffix+  , FileSuffixes, FileSuffixesWith+  , FileSuffix, FileSuffixWith   , mkInitSearchPath, searchPathFromFPath, searchPathFromFPaths   , searchPathFromString   , searchFPathFromLoc-  , searchLocationsForReadableFiles, searchPathForReadableFiles, searchPathForReadableFile+  , searchLocationsForReadableFilesWith+  , searchLocationsForReadableFiles+  , searchPathForReadableFiles+  , searchPathForReadableFile    , fpathEnsureExists @@ -351,7 +355,11 @@  type SearchPath = [String] type FileSuffix   =  Maybe String+-- | FileSuffix with extra payload+type FileSuffixWith x =  (Maybe String, x) type FileSuffixes = [FileSuffix]+-- | FileSuffix with extra payload+type FileSuffixesWith x = [FileSuffixWith x]  searchPathFromFPaths :: [FPath] -> SearchPath searchPathFromFPaths fpL = nub [ d | (Just d) <- map fpathMbDir fpL ] ++ [""]@@ -376,14 +384,51 @@ searchFPathFromLoc loc fp = [(loc,fpathPrependDir loc fp)]  -- | Search for file in locations, with possible suffices+searchLocationsForReadableFilesWith+  ::    (loc -> FPath -> [(loc,FPath,[e])])             -- ^ get the locations for a name, possibly with errors+     -> Bool                                            -- ^ stop when first is found+     -> [loc]                                           -- ^ locations to search+     -> FileSuffixesWith s                              -- ^ suffixes to try, with associated info+     -> FPath                                           -- ^ search for a path+     -> IO [(FPath,loc,s,[e])]+searchLocationsForReadableFilesWith getfp stopAtFirst locs suffs fp+  = let select stop f fps+          = foldM chk [] fps+          where chk r fp+                  = case r of+                      (_:_) | stop -> return r+                      _            -> do r' <- f fp+                                         return (r ++ r')+        tryToOpen loc (mbSuff,suffinfo) fp+          = do { let fp' = maybe fp (\suff -> fpathSetNonEmptySuff suff fp) mbSuff+               ; fExists <- doesFileExist (fpathToStr fp')+               -- ; hPutStrLn stderr (show fp ++ " - " ++ show fp')+               ; if fExists+                 then return [(fp',loc,suffinfo)]+                 else return []+               }+        tryToOpenWithSuffs suffs (loc,fp,x)+          = fmap (map (tup123to1234 x)) $+            case suffs of+              [] -> tryToOpen loc (Nothing,panic "searchLocationsForReadableFilesWith.tryToOpenWithSuffs.tryToOpen") fp+              _  -> select stopAtFirst+                      (\(ms,f) -> tryToOpen loc ms f)+                      ({- (Nothing,fp) : -} zip suffs (repeat fp))+        tryToOpenInDir loc+          = select True (tryToOpenWithSuffs suffs) (getfp loc fp)+     in select True tryToOpenInDir locs++-- | Search for file in locations, with possible suffices searchLocationsForReadableFiles-  ::    (loc -> FPath -> [(loc,FPath,[e])])				-- ^ get the locations for a name, possibly with errors-     -> Bool											-- ^ stop when first is found-     -> [loc]											-- ^ locations to search-     -> FileSuffixes									-- ^ suffixes to try-     -> FPath											-- ^ search for a path+  ::    (loc -> FPath -> [(loc,FPath,[e])])             -- ^ get the locations for a name, possibly with errors+     -> Bool                                            -- ^ stop when first is found+     -> [loc]                                           -- ^ locations to search+     -> FileSuffixes                                    -- ^ suffixes to try+     -> FPath                                           -- ^ search for a path      -> IO [(FPath,loc,[e])] searchLocationsForReadableFiles getfp stopAtFirst locs suffs fp+  = fmap (map tup1234to124) $ searchLocationsForReadableFilesWith getfp stopAtFirst locs (map (flip (,) ()) suffs) fp+{-   = let select stop f fps           = foldM chk [] fps           where chk r fp@@ -409,6 +454,7 @@         tryToOpenInDir loc           = select True (tryToOpenWithSuffs suffs) (getfp loc fp)      in select True tryToOpenInDir locs+-}  searchPathForReadableFiles :: Bool -> SearchPath -> FileSuffixes -> FPath -> IO [FPath] searchPathForReadableFiles stopAtFirst locs suffs fp

@@ -14,7 +14,7 @@  import           Prelude hiding (null,map) import           Data.Monoid-import qualified Data.ListLike as LL+-- import qualified Data.ListLike as LL import qualified Data.List as L import qualified UHC.Util.Utils as U 

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, TypeSynonymInstances #-}  ------------------------------------------------------------------------- -- Wrapper module around pretty printing@@ -86,6 +86,7 @@ import UHC.Util.PrettySimple import UHC.Util.Utils import UHC.Util.FPath+import UHC.Util.Time import System.IO import Data.List @@ -411,6 +412,12 @@  instance PP Bool where   pp = pp . show++instance PP ClockTime where+  pp = pp . show++instance PP FPath where+  pp = pp . fpathToStr  instance (PP a, PP b) => PP (a,b) where   pp (a,b) = "(" >|< a >-|-< "," >|< b >-|-< ")"

@@ -75,7 +75,7 @@       { sgeScpId    :: !Int                         -- ^ scope ident       , sgeVal      :: v                            -- ^ the value       }-  deriving (Typeable, Data)+  deriving (Typeable, Data, Generic)  type SMap k v = VarMp' k [SGamElt v] @@ -88,7 +88,7 @@       , sgScp       :: !Scp                         -- ^ scope stack       , sgMap       :: SMap k v                     -- ^ map holding the values       }-  deriving (Typeable, Data)+  deriving (Typeable, Data, Generic)  mkSGam :: SMap k v -> SGam k v mkSGam = SGam 0 [0]@@ -286,12 +286,12 @@   = g {sgMap = mapFilterInScp' scp (\(e:_) -> [e]) m}  instance (Serialize v) => Serialize (SGamElt v) where-  sput (SGamElt a b) = sput a >> sput b-  sget = liftM2 SGamElt sget sget+  -- sput (SGamElt a b) = sput a >> sput b+  -- sget = liftM2 SGamElt sget sget  instance (Ord k, Serialize k, Serialize v) => Serialize (SGam k v) where-  sput (SGam a b c) = sput a >> sput b >> sput c-  sget = liftM3 SGam sget sget sget+  -- sput (SGam a b c) = sput a >> sput b >> sput c+  -- sget = liftM3 SGam sget sget sget  -- instance (Binary v) => Serialize (SGamElt v) -- instance (Ord k, Binary k, Binary v) => Serialize (SGam k v)

@@ -69,6 +69,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +-- for generics+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+ module UHC.Util.Serialize     ( SPut     , SGet@@ -83,6 +89,7 @@     , serialize, unserialize     , putSPutFile, getSGetFile     , putSerializeFile, getSerializeFile+    , Generic     )   where import qualified UHC.Util.Binary as Bn@@ -102,6 +109,10 @@ import qualified Control.Monad.State as St import           Control.Monad.Trans +-- for generics+import           GHC.Generics+import           Control.Applicative+ {- | Serialization with state. Shared values are stored in a per type map, to keep all type correct. To make this work a double mapping is maintained, keyed by the type@@ -168,7 +179,12 @@  class Serialize x where   sput :: x -> SPut+  default sput :: (Generic x, GSerialize (Rep x)) => x -> SPut+  sput = gsput . from+   sget :: SGet x+  default sget :: (Generic x, GSerialize (Rep x)) => SGet x+  sget = to <$> gsget    sputNested :: x -> SPut   sgetNested :: SGet x@@ -368,12 +384,12 @@ -}  instance (Serialize a, Serialize b) => Serialize (a,b) where-    sput (a,b)           = sput a >> sput b-    sget                 = liftM2 (,) sget sget+    -- sput (a,b)           = sput a >> sput b+    -- sget                 = liftM2 (,) sget sget  instance (Serialize a, Serialize b, Serialize c) => Serialize (a,b,c) where-    sput (a,b,c)         = sput a >> sput b >> sput c-    sget                 = liftM3 (,,) sget sget sget+    -- sput (a,b,c)         = sput a >> sput b >> sput c+    -- sget                 = liftM3 (,,) sget sget sget  instance Serialize a => Serialize [a] where     sput l  = sput (length l) >> mapM_ sput l@@ -381,13 +397,13 @@                  replicateM n sget  instance (Serialize a) => Serialize (Maybe a) where-    sput Nothing  = sputWord8 0-    sput (Just x) = sputWord8 1 >> sput x-    sget = do-        w <- sgetWord8-        case w of-            0 -> return Nothing-            _ -> liftM Just sget+    -- sput Nothing  = sputWord8 0+    -- sput (Just x) = sputWord8 1 >> sput x+    -- sget = do+    --     w <- sgetWord8+    --     case w of+    --         0 -> return Nothing+    --         _ -> liftM Just sget  instance (Ord a, Serialize a) => Serialize (Set.Set a) where     sput = sput . Set.toAscList@@ -449,3 +465,73 @@        ; return b ;        } +-- generic serialize++class GSerialize x where+  gsget :: SGet (x y)+  gsput :: x y -> SPut++instance (Datatype d, SerializeSum x) => GSerialize (D1 d x) where+  --+  gsget = M1 <$> sumGetTagged+  --+  gsput (M1 x) = sumPutTagged x++class SerializeSum x where+  sumGetTagged :: SGet (x y)+  sumPutTagged :: x y -> SPut++instance (SerializeProduct x, Constructor c) => SerializeSum (C1 c x) where+  --+  sumGetTagged = M1 <$> productGetMVec+  {-# INLINE sumGetTagged #-}+  --+  sumPutTagged (M1 x) = productPutMVec x+  {-# INLINE sumPutTagged #-}++instance (SerializeSum a, SerializeSum b) => SerializeSum (a :+: b) where+  sumGetTagged = do+    x <- sgetWord8+    case x of+      0 -> L1 <$> sumGetTagged+      1 -> R1 <$> sumGetTagged+  {-# INLINE sumGetTagged #-}++  sumPutTagged (L1 x) = sputWord8 0 >> sumPutTagged x+  sumPutTagged (R1 x) = sputWord8 1 >> sumPutTagged x+  {-# INLINE sumPutTagged #-}++class SerializeProduct x where+  productGetMVec :: SGet (x y)+  productPutMVec :: x y -> SPut++instance (SerializeProduct a, SerializeProduct b) => SerializeProduct (a :*: b) where+  productGetMVec =+      (:*:) <$> productGetMVec+            <*> productGetMVec+  {-# INLINE productGetMVec #-}++  productPutMVec (a :*: b) = do+      productPutMVec a+      productPutMVec b+  {-# INLINE productPutMVec #-}++instance SerializeProduct x => SerializeProduct (S1 s x) where+  productGetMVec = M1 <$> productGetMVec+  {-# INLINE productGetMVec #-}++  productPutMVec (M1 x) = productPutMVec x+  {-# INLINE productPutMVec #-}++instance Serialize x => SerializeProduct (K1 i x) where+  productGetMVec = K1 <$> sget+  {-# INLINE productGetMVec #-}++  productPutMVec (K1 x) = sput x+  {-# INLINE productPutMVec #-}++instance SerializeProduct U1 where+  productGetMVec = return U1+  {-# INLINE productGetMVec #-}+  productPutMVec _ = return ()+  {-# INLINE productPutMVec #-}

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, DefaultSignatures, FlexibleContexts, UndecidableInstances #-}  module UHC.Util.Utils   ( -- * Set@@ -24,7 +25,38 @@   , tup123to1, tup123to2   , tup123to12, tup123to23   , tup12to123+  +  , fst3+  , snd3+  , thd3+  , thd +  +  , tup1234to1  +  , tup1234to2  +  , tup1234to3  +  , tup1234to4  +  +  , tup1234to12+  , tup1234to13+  , tup1234to14+  , tup1234to23+  , tup1234to24+  , tup1234to34+  +  , tup1234to123+  , tup1234to234+  +  , tup1234to124+  , tup1234to134+  +  , tup123to1234 +  , fst4+  , snd4+  , thd4+  , fth4+  , fth +       -- * String   , strWhite   , strPad@@ -34,8 +66,10 @@      , splitForQualified   -    -- * Show-  , showUnprefixedWithTypeable+    -- * Show utils+  , showUnprefixedWithShowTypeable+  , DataAndConName(..)+  , showUnprefixed        -- * Misc   , panic@@ -68,6 +102,7 @@        -- * Monad   , firstMaybeM+  , breakM   )   where @@ -75,6 +110,7 @@ import Data.Char import Data.List import Data.Typeable+import GHC.Generics import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Graph as Graph@@ -186,18 +222,76 @@ -- Tupling, untupling ------------------------------------------------------------------------- -tup123to1  (a,_,_) = a          -- aka fst3-tup123to2  (_,a,_) = a          -- aka snd3-tup123to12 (a,b,_) = (a,b)-tup123to23 (_,a,b) = (a,b)-tup12to123 c (a,b) = (a,b,c)-+tup123to1  (a,_,_) = a+tup123to2  (_,a,_) = a+tup123to3  (_,_,a) = a {-# INLINE tup123to1  #-} {-# INLINE tup123to2  #-}+{-# INLINE tup123to3  #-}++tup123to12 (a,b,_) = (a,b)+tup123to23 (_,a,b) = (a,b) {-# INLINE tup123to12 #-} {-# INLINE tup123to23 #-}++tup12to123 c (a,b) = (a,b,c) {-# INLINE tup12to123 #-} +fst3 = tup123to1+snd3 = tup123to2+thd3 = tup123to3+thd  = thd3+{-# INLINE fst3 #-}+{-# INLINE snd3 #-}+{-# INLINE thd3 #-}+{-# INLINE thd  #-}++tup1234to1   (a,_,_,_) = a+tup1234to2   (_,a,_,_) = a+tup1234to3   (_,_,a,_) = a+tup1234to4   (_,_,_,a) = a+{-# INLINE tup1234to1   #-}+{-# INLINE tup1234to2   #-}+{-# INLINE tup1234to3   #-}+{-# INLINE tup1234to4   #-}++tup1234to12  (a,b,_,_) = (a,b)+tup1234to13  (a,_,b,_) = (a,b)+tup1234to14  (a,_,_,b) = (a,b)+tup1234to23  (_,a,b,_) = (a,b)+tup1234to24  (_,a,_,b) = (a,b)+tup1234to34  (_,_,a,b) = (a,b)+{-# INLINE tup1234to12 #-}+{-# INLINE tup1234to13 #-}+{-# INLINE tup1234to14 #-}+{-# INLINE tup1234to23 #-}+{-# INLINE tup1234to24 #-}+{-# INLINE tup1234to34 #-}++tup1234to123 (a,b,c,_) = (a,b,c)+tup1234to234 (_,a,b,c) = (a,b,c)+{-# INLINE tup1234to123 #-}+{-# INLINE tup1234to234 #-}++tup1234to124 (a,b,_,c) = (a,b,c)+tup1234to134 (a,_,b,c) = (a,b,c)+{-# INLINE tup1234to124 #-}+{-# INLINE tup1234to134 #-}++tup123to1234 d (a,b,c) = (a,b,c,d)+{-# INLINE tup123to1234 #-}++fst4 = tup1234to1+snd4 = tup1234to2+thd4 = tup1234to3+fth4 = tup1234to4+fth  = fth4+{-# INLINE fst4 #-}+{-# INLINE snd4 #-}+{-# INLINE thd4 #-}+{-# INLINE fth4 #-}+{-# INLINE fth  #-}+ ------------------------------------------------------------------------- -- String -------------------------------------------------------------------------@@ -232,10 +326,37 @@ -------------------------------------------------------------------------  -- | Show, additionally removing type name prefix, assuming constructor names are prefixed with type name, possibly with additional underscore (or something like that)-showUnprefixedWithTypeable :: (Show x, Typeable x) => Int -> x -> String-showUnprefixedWithTypeable extralen x = drop prelen $ show x+showUnprefixedWithShowTypeable :: (Show x, Typeable x) => Int -> x -> String+showUnprefixedWithShowTypeable extralen x = drop prelen $ show x   where prelen = (length $ show $ typeOf x) + extralen +-- | Generic constructor name, to be used by show variations+class GDataAndConName f where+  gDataAndConName :: f x -> (String,String)++class DataAndConName x where+  -- | Get datatype and constructor name for a datatype+  dataAndConName :: x -> (String,String)+  +  default dataAndConName :: (Generic x, GDataAndConName (Rep x)) => x -> (String,String)+  dataAndConName = gDataAndConName . from++instance (Datatype d, GDataAndConName x) => GDataAndConName (D1 d x) where+  gDataAndConName d@(M1 x) = let (_,c) = gDataAndConName x in (datatypeName d, c)++instance (GDataAndConName a, GDataAndConName b) => GDataAndConName (a :+: b) where+  gDataAndConName (L1 x) = gDataAndConName x+  gDataAndConName (R1 x) = gDataAndConName x++instance (Constructor c) => GDataAndConName (C1 c x) where+  gDataAndConName c = ("", conName c)++-- | Show, additionally removing type name prefix, assuming constructor names are prefixed with type name, possibly with additional underscore (or something like that)+showUnprefixed :: (DataAndConName x) => Int -> x -> String+showUnprefixed extralen x = drop prelen $ c+  where (d,c) = dataAndConName x+        prelen = (length d) + extralen+ ------------------------------------------------------------------------- -- Split for qualified name -------------------------------------------------------------------------@@ -396,3 +517,9 @@ firstMaybeM x []     = return x firstMaybeM x (s:ss) = do mx <- s x                           maybe (firstMaybeM x ss) return mx++-- | Monadic equivalent of break: evaluate monads until a predicate is True, returning what is yes/no evaluated and the split point+breakM :: Monad m => (a -> Bool) -> [m a] -> m ([a], Maybe (a,[m a]))+breakM p l = br [] l >>= \(acc,res) -> return (reverse acc, res)+  where br acc []     = return (acc, Nothing)+        br acc (m:ms) = m >>= \x -> if p x then return (acc, Just (x, ms)) else br (x:acc) ms

@@ -18,7 +18,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverlappingInstances #-}+-- {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE DeriveGeneric #-}  module UHC.Util.VarMp     ( VarMp'(..)@@ -112,7 +113,7 @@       , varmpMpL        :: [Map.Map k v]        -- ^ for each level a map, starting at the base meta level       }   deriving ( Eq, Ord-           , Typeable, Data+           , Typeable, Data, Generic            )  -- get the base meta level map, ignore the others@@ -571,6 +572,6 @@ -}  instance (Ord k, Serialize k, Serialize v) => Serialize (VarMp' k v) where-  sput (VarMp a b) = sput a >> sput b-  sget = liftM2 VarMp sget sget+  -- sput (VarMp a b) = sput a >> sput b+  -- sget = liftM2 VarMp sget sget 

@@ -1,5 +1,5 @@ Name:				uhc-util-Version:			0.1.6.0+Version:			0.1.6.2 cabal-version:      >= 1.6 License:			BSD3 Copyright:			Utrecht University, Department of Information and Computing Sciences, Software Technology group@@ -21,7 +21,7 @@  library   Build-Depends:-    base >= 4 && < 5,+    base >= 4.6 && < 5,     mtl >= 2,     fgl >= 5.4,     hashable >= 1.1,@@ -34,7 +34,6 @@     uulib >= 0.9.19,     time-compat >= 0.1.0.1,     time >= 1.2,-    ListLike >= 4.0.0,     fclabels >= 2.0.2,     syb  >= 0.3.6   Exposed-Modules:@@ -47,6 +46,7 @@     UHC.Util.Control.Monad,     UHC.Util.Debug,     UHC.Util.DependencyGraph,+    UHC.Util.Error,     UHC.Util.FastSeq,     UHC.Util.FPath,     UHC.Util.Hashable,