diff --git a/src/UHC/Util/CompileRun.hs b/src/UHC/Util/CompileRun.hs --- a/src/UHC/Util/CompileRun.hs +++ b/src/UHC/Util/CompileRun.hs @@ -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 diff --git a/src/UHC/Util/CompileRun2.hs b/src/UHC/Util/CompileRun2.hs --- a/src/UHC/Util/CompileRun2.hs +++ b/src/UHC/Util/CompileRun2.hs @@ -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 diff --git a/src/UHC/Util/CompileRun3.hs b/src/UHC/Util/CompileRun3.hs --- a/src/UHC/Util/CompileRun3.hs +++ b/src/UHC/Util/CompileRun3.hs @@ -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 diff --git a/src/UHC/Util/DependencyGraph.hs b/src/UHC/Util/DependencyGraph.hs --- a/src/UHC/Util/DependencyGraph.hs +++ b/src/UHC/Util/DependencyGraph.hs @@ -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 } diff --git a/src/UHC/Util/Error.hs b/src/UHC/Util/Error.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Error.hs @@ -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 diff --git a/src/UHC/Util/FPath.hs b/src/UHC/Util/FPath.hs --- a/src/UHC/Util/FPath.hs +++ b/src/UHC/Util/FPath.hs @@ -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 diff --git a/src/UHC/Util/FastSeq.hs b/src/UHC/Util/FastSeq.hs --- a/src/UHC/Util/FastSeq.hs +++ b/src/UHC/Util/FastSeq.hs @@ -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 diff --git a/src/UHC/Util/Pretty.hs b/src/UHC/Util/Pretty.hs --- a/src/UHC/Util/Pretty.hs +++ b/src/UHC/Util/Pretty.hs @@ -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 >-|-< ")" diff --git a/src/UHC/Util/ScopeMapGam.hs b/src/UHC/Util/ScopeMapGam.hs --- a/src/UHC/Util/ScopeMapGam.hs +++ b/src/UHC/Util/ScopeMapGam.hs @@ -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) diff --git a/src/UHC/Util/Serialize.hs b/src/UHC/Util/Serialize.hs --- a/src/UHC/Util/Serialize.hs +++ b/src/UHC/Util/Serialize.hs @@ -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 #-} diff --git a/src/UHC/Util/Utils.hs b/src/UHC/Util/Utils.hs --- a/src/UHC/Util/Utils.hs +++ b/src/UHC/Util/Utils.hs @@ -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 diff --git a/src/UHC/Util/VarMp.hs b/src/UHC/Util/VarMp.hs --- a/src/UHC/Util/VarMp.hs +++ b/src/UHC/Util/VarMp.hs @@ -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 diff --git a/uhc-util.cabal b/uhc-util.cabal --- a/uhc-util.cabal +++ b/uhc-util.cabal @@ -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,