uhc-util (empty) → 0.1.0.0
raw patch · 19 files changed
+2791/−0 lines, 19 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, bytestring, containers, directory, fgl, hashable, mtl, old-time, process, uulib
Files
- LICENSE +41/−0
- Setup.hs +2/−0
- src/UHC/Util/AGraph.hs +61/−0
- src/UHC/Util/Binary.hs +75/−0
- src/UHC/Util/CompileRun.hs +542/−0
- src/UHC/Util/Debug.hs +16/−0
- src/UHC/Util/DependencyGraph.hs +167/−0
- src/UHC/Util/FPath.hs +353/−0
- src/UHC/Util/FastSeq.hs +118/−0
- src/UHC/Util/Nm.hs +147/−0
- src/UHC/Util/ParseErrPrettyPrint.hs +52/−0
- src/UHC/Util/ParseUtils.hs +172/−0
- src/UHC/Util/Pretty.hs +270/−0
- src/UHC/Util/PrettySimple.hs +170/−0
- src/UHC/Util/PrettyUtils.hs +18/−0
- src/UHC/Util/Rel.hs +85/−0
- src/UHC/Util/ScanUtils.hs +187/−0
- src/UHC/Util/Utils.hs +265/−0
- uhc-util.cabal +50/−0
+ LICENSE view
@@ -0,0 +1,41 @@+The Utrecht Haskell Compiler (UHC) License+==========================================++UHC follows the advertisement free BSD license, of which the basic+template can be found here:++ http://www.opensource.org/licenses/bsd-license.php++UHC uses the following libraries with their own license:+- Library code from the GHC distribution, see comment in the modules in ehclib++License text+============++Copyright (c) 2009-2010, Utrecht University, Department of Information+and Computing Sciences, Software Technology group++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++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 COPYRIGHT+HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/UHC/Util/AGraph.hs view
@@ -0,0 +1,61 @@+-------------------------------------------------------------------------+-- Interface to inductive graph library, by Gerrit vd Geest+-------------------------------------------------------------------------++module UHC.Util.AGraph + ( AGraph(agraphGraph)+ , insertEdge+ , insertEdges+ , deleteEdge+ , deleteNode+ , successors+ , predecessors+ , emptyAGraph+ )+ where++import Data.Graph.Inductive.Graph (empty, insNodes, gelem, lab, lpre, lsuc, delEdge, delNode)+import Data.Graph.Inductive.NodeMap (NodeMap, new, mkNodes, mkNode_, insMapEdge)+import Data.Graph.Inductive.Tree (Gr)+import Data.Graph.Inductive.Graphviz (graphviz')++import Data.Maybe (fromJust)+import Data.List(nub)++data AGraph a b = AGr { agraphNodeMap :: NodeMap a, agraphGraph :: Gr a b}++instance (Show a, Show b) => Show (AGraph a b) where+ show (AGr _ gr) = graphviz' gr++insertEdges :: Ord a => [(a, a, b)] -> AGraph a b -> AGraph a b+insertEdges = flip (foldr insertEdge)++insertEdge :: Ord a => (a, a, b) -> AGraph a b -> AGraph a b+insertEdge e@(p, q, _) gr = let (AGr nm' gr') = insMapNodes (p:[q]) gr+ in AGr nm' (insMapEdge nm' e gr')++deleteEdge :: Ord a => (a, a) -> AGraph a b -> AGraph a b+deleteEdge (p, q) (AGr nm gr) = AGr nm (delEdge (getId p, getId q) gr)+ where getId nd = fst $ mkNode_ nm nd++deleteNode :: Ord a => a -> AGraph a b -> AGraph a b+deleteNode p (AGr nm gr) = AGr nm (delNode (getId p) gr)+ where getId nd = fst $ mkNode_ nm nd++insMapNodes :: Ord a => [a] -> AGraph a b -> AGraph a b+insMapNodes as (AGr m g) =+ let (ns, m') = mkNodes m (nub as)+ ns' = filter (\(i, _) -> not $ gelem i g) ns+ in AGr m' (insNodes ns' g)++successors, predecessors :: Ord a => AGraph a b -> a -> [(b, a)]+successors = neighbours lsuc+predecessors = neighbours lpre++emptyAGraph :: Ord a => AGraph a b+emptyAGraph = AGr new empty++neighbours dir (AGr nm gr) node+ | nd `gelem` gr = map (\(n, info) -> (info, fromJust $ lab gr n)) (dir gr nd)+ | otherwise = []+ where nd = fst $ mkNode_ nm node
+ src/UHC/Util/Binary.hs view
@@ -0,0 +1,75 @@+-------------------------------------------------------------------------+-- Wrapper module around Data.Binary, providing additional functionality+-------------------------------------------------------------------------++module UHC.Util.Binary+ ( module Data.Binary+ , module Data.Binary.Get+ , module Data.Binary.Put++ , hGetBinary+ , getBinaryFile+ , getBinaryFPath++ , hPutBinary+ , putBinaryFile+ , putBinaryFPath+ )+ where++import qualified Data.ByteString.Lazy as L+import Data.Binary+import Data.Binary.Put(runPut,putWord16be)+import Data.Binary.Get(runGet,getWord16be)+import System.IO+import Control.Monad++import UHC.Util.FPath++-------------------------------------------------------------------------+-- Decoding from ...+-------------------------------------------------------------------------++-- | Decode from Handle+hGetBinary :: Binary a => Handle -> IO a+hGetBinary h+ = liftM decode (L.hGetContents h)++-- | Decode from FilePath+getBinaryFile :: Binary a => FilePath -> IO a+getBinaryFile fn+ = do { h <- openBinaryFile fn ReadMode+ ; b <- hGetBinary h+ -- ; hClose h+ ; return b ;+ }++-- | Decode from FilePath+getBinaryFPath :: Binary a => FPath -> IO a+getBinaryFPath fp+ = getBinaryFile (fpathToStr fp)++-------------------------------------------------------------------------+-- Encoding to ...+-------------------------------------------------------------------------++-- | Encode to Handle+hPutBinary :: Binary a => Handle -> a -> IO ()+hPutBinary h pt+ = L.hPut h (encode pt)++-- | Encode to FilePath+putBinaryFile :: Binary a => FilePath -> a -> IO ()+putBinaryFile fn pt+ = do { h <- openBinaryFile fn WriteMode+ ; hPutBinary h pt+ ; hClose h+ }++-- | Encode to FPath, ensuring existence of path+putBinaryFPath :: Binary a => FPath -> a -> IO ()+putBinaryFPath fp pt+ = do { fpathEnsureExists fp+ ; putBinaryFile (fpathToStr fp) pt+ }+
+ src/UHC/Util/CompileRun.hs view
@@ -0,0 +1,542 @@+{-# LANGUAGE UndecidableInstances, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes #-}++-------------------------------------------------------------------------+-- Combinators for a compile run+-------------------------------------------------------------------------++module UHC.Util.CompileRun+ ( CompileRunState(..)+ , CompileRun(..)+ , CompilePhase+ , CompileUnit(..)+ , CompileUnitState(..)+ , CompileRunError(..)+ , CompileModName(..)+ , CompileRunStateInfo(..)++ , CompileParticipation(..)++ , FileLocatable(..)++ , mkEmptyCompileRun++ , crCU, crMbCU+ , ppCR++ , cpUpdStateInfo, cpUpdSI++ , cpUpdCU, cpUpdCUWithKey+ , cpSetFail, cpSetStop, cpSetStopSeq, cpSetStopAllSeq+ , cpSetOk, cpSetErrs, cpSetLimitErrs, cpSetLimitErrsWhen, cpSetInfos, cpSetCompileOrder++ , cpSeq, cpSeqWhen+ , cpEmpty++ , cpFindFileForNameOrFPath+ , cpFindFilesForFPathInLocations, cpFindFilesForFPath, cpFindFileForFPath+ , cpImportGather, cpImportGatherFromMods, cpImportGatherFromModsWithImp+ , cpPP, cpPPMsg++ , forgetM+ )+ where++import Data.Maybe+import System.Exit+import Control.Monad+import Control.Monad.State+import System.IO+import qualified Data.Map as Map+import UHC.Util.Pretty+import UHC.Util.Utils+import UHC.Util.FPath+++-------------------------------------------------------------------------+-- Utility+-------------------------------------------------------------------------++-- forget result+forgetM :: Monad m => m a -> m ()+forgetM m+ = do { _ <- m+ ; return ()+ }++-------------------------------------------------------------------------+-- The way a CompileUnit can participate+-------------------------------------------------------------------------++data CompileParticipation+ = CompileParticipation_NoImport+ deriving (Eq, Ord)++-------------------------------------------------------------------------+-- Interfacing with actual state info+-------------------------------------------------------------------------++class CompileModName n where+ mkCMNm :: String -> n++class CompileUnitState s where+ cusDefault :: s+ cusUnk :: s+ cusIsUnk :: s -> Bool+ cusIsImpKnown :: s -> Bool++class CompileUnit u n l s | u -> n l s where+ cuDefault :: u+ cuFPath :: u -> FPath+ cuUpdFPath :: FPath -> u -> u+ cuLocation :: u -> l+ cuUpdLocation :: l -> u -> u+ cuKey :: u -> n+ cuUpdKey :: n -> u -> u+ cuState :: u -> s+ cuUpdState :: s -> u -> u+ cuImports :: u -> [n]+ cuParticipation :: u -> [CompileParticipation]++ -- defaults+ cuParticipation _ = []++class FPathError e => CompileRunError e p | e -> p where+ crePPErrL :: [e] -> PP_Doc+ creMkNotFoundErrL :: p -> String -> [String] -> [FileSuffix] -> [e]+ creAreFatal :: [e] -> Bool++ -- defaults+ crePPErrL _ = empty+ creMkNotFoundErrL _ _ _ _ = []+ creAreFatal _ = True++class CompileRunStateInfo i n p where+ crsiImportPosOfCUKey :: n -> i -> p++-------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------++instance CompileRunError String p++-------------------------------------------------------------------------+-- Locatable+-------------------------------------------------------------------------++class FileLocatable x loc | loc -> x where -- funcdep has unlogical direction, but well...+ fileLocation :: x -> loc+ noFileLocation :: loc++-------------------------------------------------------------------------+-- State+-------------------------------------------------------------------------++data CompileRunState err+ = CRSOk -- continue+ | CRSFail -- fail and stop+ | CRSStopSeq -- stop current cpSeq+ | CRSStopAllSeq -- stop current cpSeq, but also the surrounding ones+ | CRSStop -- stop completely+ | CRSFailErrL String [err] (Maybe Int) -- fail with errors and stop+ | CRSErrInfoL String Bool [err] -- just errors, continue++data CompileRun nm unit info err+ = CompileRun+ { crCUCache :: Map.Map nm unit+ , crCompileOrder :: [[nm]]+ , crTopModNm :: nm+ , crState :: CompileRunState err+ , crStateInfo :: info+ }++instance Show (CompileRunState err) where+ show CRSOk = "CRSOk"+ show CRSFail = "CRSFail"+ show CRSStopSeq = "CRSStopSeq"+ show CRSStopAllSeq = "CRSStopAllSeq"+ show CRSStop = "CRSStop"+ show (CRSFailErrL _ _ _) = "CRSFailErrL"+ show (CRSErrInfoL _ _ _) = "CRSErrInfoL"++type CompilePhase n u i e a = StateT (CompileRun n u i e) IO a++++mkEmptyCompileRun :: n -> i -> CompileRun n u i e+mkEmptyCompileRun nm info+ = CompileRun+ { crCUCache = Map.empty+ , crCompileOrder = []+ , crTopModNm = nm+ , crState = CRSOk+ , crStateInfo = info+ }++-------------------------------------------------------------------------+-- Pretty printing+-------------------------------------------------------------------------++ppCR :: (PP n,PP u) => CompileRun n u i e -> PP_Doc+ppCR cr+ = "CR" >#< show (crState cr) >|< ":" >#<+ ( (ppListSepVV "[" "]" "," $ map (\(n,u) -> pp n >#< "->" >#< pp u) $ Map.toList $ crCUCache $ cr)+ >-< ppBracketsCommas (map ppBracketsCommas $ crCompileOrder $ cr)+ )++crPP :: (PP n,PP u) => String -> CompileRun n u i e -> IO (CompileRun n u i e)+crPP m cr = do { hPutStrLn stderr (m ++ ":") ; hPutPPLn stderr (ppCR cr) ; hFlush stderr ; return cr }++crPPMsg :: (PP m) => m -> CompileRun n u i e -> IO (CompileRun n u i e)+crPPMsg m cr = do { hPutPPLn stdout (pp m) ; return cr }++cpPP :: (PP n,PP u) => String -> CompilePhase n u i e ()+cpPP m+ = do { lift (hPutStrLn stderr (m ++ ":"))+ ; cr <- get+ ; lift (hPutPPLn stderr (ppCR cr))+ ; lift (hFlush stderr)+ ; return ()+ }++cpPPMsg :: (PP m) => m -> CompilePhase n u i e ()+cpPPMsg m+ = do { lift (hPutPPLn stdout (pp m))+ ; return ()+ }++++-------------------------------------------------------------------------+-- State manipulation, sequencing: compile unit+-------------------------------------------------------------------------++crMbCU :: Ord n => n -> CompileRun n u i e -> Maybe u+crMbCU modNm cr = Map.lookup modNm (crCUCache cr)++crCU :: (Show n,Ord n) => n -> CompileRun n u i e -> u+crCU modNm = panicJust ("crCU: " ++ show modNm) . crMbCU modNm++-------------------------------------------------------------------------+-- State manipulation, sequencing: non monadic+-------------------------------------------------------------------------++crSetFail :: CompileRun n u i e -> CompileRun n u i e+crSetFail cr = cr {crState = CRSFail}++crSetStop :: CompileRun n u i e -> CompileRun n u i e+crSetStop cr = cr {crState = CRSStop}++crSetStopSeq :: CompileRun n u i e -> CompileRun n u i e+crSetStopSeq cr = cr {crState = CRSStopSeq}++crSetStopAllSeq :: CompileRun n u i e -> CompileRun n u i e+crSetStopAllSeq cr = cr {crState = CRSStopAllSeq}++crSetErrs' :: Maybe Int -> String -> [e] -> CompileRun n u i e -> CompileRun n u i e+crSetErrs' limit about es cr+ = case es of+ [] -> cr+ _ -> cr {crState = CRSFailErrL about es limit}++crSetInfos' :: String -> Bool -> [e] -> CompileRun n u i e -> CompileRun n u i e+crSetInfos' msg dp is cr+ = case is of+ [] -> cr+ _ -> cr {crState = CRSErrInfoL msg dp is}++-------------------------------------------------------------------------+-- Compile unit observations+-------------------------------------------------------------------------++crCUState :: (Ord n,CompileUnit u n l s,CompileUnitState s) => n -> CompileRun n u i e -> s+crCUState modNm cr = maybe cusUnk cuState (crMbCU modNm cr)++crCUFPath :: (Ord n,CompileUnit u n l s) => n -> CompileRun n u i e -> FPath+crCUFPath modNm cr = maybe emptyFPath cuFPath (crMbCU modNm cr)++crCULocation :: (Ord n,FileLocatable u loc) => n -> CompileRun n u i e -> loc+crCULocation modNm cr = maybe noFileLocation fileLocation (crMbCU modNm cr)++-------------------------------------------------------------------------+-- Find file for FPath+-------------------------------------------------------------------------++cpFindFileForNameOrFPath :: (FPATH n) => String -> n -> FPath -> [(String,FPath)]+cpFindFileForNameOrFPath loc _ fp = searchFPathFromLoc loc fp++cpFindFilesForFPathInLocations+ :: ( 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])]) -> ((FPath,loc,[e]) -> res)+ -> Bool -> [(FileSuffix,s)] -> [loc] -> Maybe n -> Maybe FPath -> CompilePhase n u i e [res]+cpFindFilesForFPathInLocations getfp putres stopAtFirst suffs locs mbModNm mbFp+ = do { cr <- get+ ; let cus = maybe cusUnk (flip crCUState cr) mbModNm+ ; if cusIsUnk cus+ then do { let fp = maybe (mkFPath $ panicJust ("cpFindFileForFPath") $ mbModNm) id mbFp+ modNm = maybe (mkCMNm $ fpathBase $ fp) id mbModNm+ suffs' = map fst suffs+ ; fpsFound <- lift (searchLocationsForReadableFiles (\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@(_:_)):_)+ -> do { cpSetErrs e+ ; return []+ }+ ffs@((ff,loc,_):_)+ -> do { cpUpdCU modNm (cuUpdLocation loc . cuUpdFPath ff . cuUpdState cus . cuUpdKey modNm)+ ; return (map putres ffs)+ }+ where cus = case lookup (Just $ fpathSuff ff) suffs of+ Just c -> c+ Nothing -> case lookup (Just "*") suffs of+ Just c -> c+ Nothing -> cusUnk+ }+ else return (maybe [] (\nm -> [putres (crCUFPath nm cr,crCULocation nm cr,[])]) mbModNm)+ }++cpFindFilesForFPath+ :: forall e n u p i s .+ ( Ord n+ , FPATH n, FileLocatable u String+ , CompileUnitState s,CompileRunError e p,CompileUnit u n String s,CompileModName n,CompileRunStateInfo i n p+ ) => Bool -> [(FileSuffix,s)] -> [String] -> Maybe n -> Maybe FPath -> CompilePhase n u i e [FPath]+cpFindFilesForFPath+ = cpFindFilesForFPathInLocations (\l n f -> map (tup12to123 ([]::[e])) $ cpFindFileForNameOrFPath l n f) tup123to1++cpFindFileForFPath+ :: ( Ord n+ , FPATH n, FileLocatable u String+ , CompileUnitState s,CompileRunError e p,CompileUnit u n String s,CompileModName n,CompileRunStateInfo i n p+ ) => [(FileSuffix,s)] -> [String] -> Maybe n -> Maybe FPath -> CompilePhase n u i e (Maybe FPath)+cpFindFileForFPath suffs sp mbModNm mbFp+ = do { fps <- cpFindFilesForFPath True suffs sp mbModNm mbFp+ ; return (listToMaybe fps)+ }++-------------------------------------------------------------------------+-- Gather all imports+-------------------------------------------------------------------------++-- | recursively extract imported modules, providing a way to import + do the import+cpImportGatherFromModsWithImp+ :: (Show n, Ord n, CompileUnit u n l s, CompileRunError e p, CompileUnitState s)+ => (u -> [n]) -- get imports+ -> (Maybe prev -> n -> CompilePhase n u i e (x,Maybe prev)) -- extract imports from 1 module+ -> [n] -- to be imported modules+ -> CompilePhase n u i e ()+cpImportGatherFromModsWithImp getImports imp1Mod modNmL+ = do { cr <- get+ ; cpSeq ( [ one Nothing modNm | modNm <- modNmL ]+ ++ [ cpImportScc ]+ )+ }+ where one prev modNm+ = do { (_,new) <- imp1Mod prev modNm+ ; cpHandleErr+ ; cr <- get+ ; if CompileParticipation_NoImport `elem` cuParticipation (crCU modNm cr)+ then cpDelCU modNm+ else imps new modNm+ }+ imps prev m+ = do { cr <- get+ ; let impL m = [ i | i <- getImports (crCU m cr), not (cusIsImpKnown (crCUState i cr)) ]+ ; cpSeq (map (\n -> one prev n) (impL m))+ }++-- | recursively extract imported modules+cpImportGatherFromMods+ :: (Show n, Ord n, CompileUnit u n l s, CompileRunError e p, CompileUnitState s)+ => (Maybe prev -> n -> CompilePhase n u i e (x,Maybe prev)) -- extract imports from 1 module+ -> [n] -- to be imported modules+ -> CompilePhase n u i e ()+cpImportGatherFromMods = cpImportGatherFromModsWithImp cuImports++-- | Abbreviation for cpImportGatherFromMods for 1 module+cpImportGather+ :: (Show n,Ord n,CompileUnit u n l s,CompileRunError e p,CompileUnitState s)+ => (n -> CompilePhase n u i e ()) -> n -> CompilePhase n u i e ()+cpImportGather imp1Mod modNm+ = cpImportGatherFromMods+ (\_ n -> do { r <- imp1Mod n+ ; return (r,Nothing)+ }+ )+ [modNm]++crImportDepL :: (CompileUnit u n l s) => CompileRun n u i e -> [(n,[n])]+crImportDepL = map (\cu -> (cuKey cu,cuImports cu)) . Map.elems . crCUCache++cpImportScc :: (Ord n,CompileUnit u n l s) => CompilePhase n u i e ()+cpImportScc = modify (\cr -> (cr {crCompileOrder = scc (crImportDepL cr)}))+++-------------------------------------------------------------------------+-- State manipulation, state update (Monadic)+-------------------------------------------------------------------------++cpUpdStateInfo, cpUpdSI :: (i -> i) -> CompilePhase n u i e ()+cpUpdStateInfo upd+ = do { cr <- get+ ; put (cr {crStateInfo = upd (crStateInfo cr)})+ }++cpUpdSI = cpUpdStateInfo++-------------------------------------------------------------------------+-- State manipulation, compile unit update (Monadic)+-------------------------------------------------------------------------++cpUpdCUM :: (Ord n,CompileUnit u n l s) => n -> (u -> IO u) -> CompilePhase n u i e ()+cpUpdCUM modNm upd+ = do { cr <- get+ ; cu <- lift (maybe (upd cuDefault) upd (crMbCU modNm cr))+ ; put (cr {crCUCache = Map.insert modNm cu (crCUCache cr)})+ }+++cpUpdCUWithKey :: (Ord n,CompileUnit u n l s) => n -> (n -> u -> (n,u)) -> CompilePhase n u i e n+cpUpdCUWithKey modNm upd+ = do { cr <- get+ ; let (modNm',cu) = (maybe (upd modNm cuDefault) (upd modNm) (crMbCU modNm cr))+ ; put (cr {crCUCache = Map.insert modNm' cu $ Map.delete modNm $ crCUCache cr})+ ; return modNm'+ }++cpUpdCU :: (Ord n,CompileUnit u n l s) => n -> (u -> u) -> CompilePhase n u i e ()+cpUpdCU modNm upd+ = do { cpUpdCUWithKey modNm (\k u -> (k, upd u))+ ; return ()+ }++-- | delete unit+cpDelCU :: (Ord n,CompileUnit u n l s) => n -> CompilePhase n u i e ()+cpDelCU modNm+ = do { modify (\cr -> cr {crCUCache = Map.delete modNm $ crCUCache cr})+ }+{-+ = do { cr <- get+ ; let cu = (maybe (upd cuDefault) upd (crMbCU modNm cr))+ ; put (cr {crCUCache = Map.insert modNm cu (crCUCache cr)})+ }+-}+{-+cpUpdCU modNm upd+ = cpUpdCUM modNm (return . upd)+-}++-------------------------------------------------------------------------+-- State manipulation, sequencing (Monadic)+-------------------------------------------------------------------------++cpSetErrs :: [e] -> CompilePhase n u i e ()+cpSetErrs es+ = modify (crSetErrs' Nothing "" es)++cpSetInfos :: String -> Bool -> [e] -> CompilePhase n u i e ()+cpSetInfos msg dp is+ = modify (crSetInfos' msg dp is)++cpSetFail :: CompilePhase n u i e ()+cpSetFail+ = modify crSetFail++cpSetStop :: CompilePhase n u i e ()+cpSetStop+ = modify crSetStop++cpSetStopSeq :: CompilePhase n u i e ()+cpSetStopSeq+ = modify crSetStopSeq++cpSetStopAllSeq :: CompilePhase n u i e ()+cpSetStopAllSeq+ = modify crSetStopAllSeq++cpSetOk :: CompilePhase n u i e ()+cpSetOk+ = modify (\cr -> (cr {crState = CRSOk}))++cpSetCompileOrder :: [[n]] -> CompilePhase n u i e ()+cpSetCompileOrder nameLL+ = modify (\cr -> (cr {crCompileOrder = nameLL}))++cpSetLimitErrs, cpSetLimitErrsWhen :: Int -> String -> [e] -> CompilePhase n u i e ()+cpSetLimitErrs l a e+ = modify (crSetErrs' (Just l) a e)++cpSetLimitErrsWhen l a e+ = do { when (not (null e))+ (cpSetLimitErrs l a e)+ }++cpEmpty :: CompilePhase n u i e ()+cpEmpty = return ()++-- sequence of phases, each may stop the whole sequencing+cpSeq :: CompileRunError e p => [CompilePhase n u i e ()] -> CompilePhase n u i e ()+cpSeq [] = return ()+cpSeq (a:as) = do { a+ ; cpHandleErr+ ; cr <- get+ ; case crState cr of+ CRSOk -> cpSeq as+ CRSStopSeq -> cpSetOk+ CRSStopAllSeq -> cpSetStopAllSeq+ _ -> return ()+ }++-- conditional sequence+cpSeqWhen :: CompileRunError e p => Bool -> [CompilePhase n u i e ()] -> CompilePhase n u i e ()+cpSeqWhen True as = cpSeq as+cpSeqWhen _ _ = return ()++-- handle possible error in sequence+cpHandleErr :: CompileRunError e p => CompilePhase n u i e ()+cpHandleErr+ = do { cr <- get+ ; case crState cr of+ CRSFailErrL about es (Just lim)+ -> do { let (showErrs,omitErrs) = splitAt lim es+ ; lift (unless (null about) (hPutPPLn stderr (pp about)))+ ; lift (putErr' (if null omitErrs then return () else hPutStrLn stderr "... and more errors") showErrs)+ ; failOrNot es+ }+ CRSFailErrL about es Nothing+ -> do { lift (unless (null about) (hPutPPLn stderr (pp about)))+ ; lift (putErr' (return ()) es)+ ; failOrNot es+ }+ CRSErrInfoL about doPrint is+ -> do { if null is+ then return ()+ else lift (do { hFlush stdout+ ; hPutPPLn stderr (about >#< "found errors" >-< e)+ })+ ; if not (null is) then lift exitFailure else return ()+ }+ where e = empty -- if doPrint then crePPErrL is else empty+ CRSFail+ -> do { lift exitFailure+ }+ CRSStop+ -> do { lift $ exitWith ExitSuccess+ }+ _ -> return ()+ }+ where putErr' m e = if null e+ then return ()+ else do { hPutPPLn stderr (crePPErrL e)+ ; m+ ; hFlush stderr+ }+ failOrNot es = if creAreFatal es then lift exitFailure else cpSetOk+
+ src/UHC/Util/Debug.hs view
@@ -0,0 +1,16 @@+module UHC.Util.Debug+ ( tr, trp+ )+ where++import UHC.Util.Pretty+import UHC.Util.PrettyUtils+import Debug.Trace++-------------------------------------------------------------------------+-- Tracing+-------------------------------------------------------------------------++tr m s v = trace (m ++ show s) v+trp m s v = trace (m ++ "\n" ++ disp (m >|< ":" >#< s) 1000 "") v+
+ src/UHC/Util/DependencyGraph.hs view
@@ -0,0 +1,167 @@+-------------------------------------------------------------------------+-- Graph for version/view dpd+-------------------------------------------------------------------------++module UHC.Util.DependencyGraph+ ( DpdGr+ , dgTopSort+ , dgVertices+ , dgReachableFrom, dgReachableTo+ , dgDpdsOn+ , dgIsFirst+ , dgCheckSCCMutuals+ , dgSCCToList+ , mkDpdGrFromEdges+ , mkDpdGrFromEdgesMp, mkDpdGrFromEdgesMpPadMissing+ , mkDpdGrFromAssocWithMissing+ , mkDpdGrFromOrderWithMissing+ )+ where++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Graph+import UHC.Util.Pretty+-- import UHC.Util.Nm+-- import Err++-------------------------------------------------------------------------+-- DpdGr+-------------------------------------------------------------------------++data DpdGr n+ = DpdGr+ { dgGr :: Graph+ , dgGrT :: Graph+ , dgEdges :: [(n, n, [n])]+ , dgV2N :: Vertex -> (n, [n])+ , dgK2V :: n -> Maybe Vertex+ }++emptyDpdGr :: Ord n => DpdGr n+emptyDpdGr = mkDpdGrFromOrderWithMissing [] []++-------------------------------------------------------------------------+-- Pretty printing+-------------------------------------------------------------------------++instance Show (DpdGr n) where+ show _ = "DpdGr"++instance (Ord n,PP n) => PP (DpdGr n) where+ pp g = "DpdGr" >#< ("topsort:" >#< ppCommas (dgTopSort g) >-< "scc :" >#< ppBracketsCommas (dgSCC g) >-< "edges :" >#< (ppBracketsCommas $ map (\(n,_,ns) -> n >|< ":" >|< ppBracketsCommas ns) $ dgEdges $ g))++instance Show (SCC n) where+ show _ = "SCC"++instance PP n => PP (SCC n) where+ pp (AcyclicSCC n ) = "ASCC" >#< n+ pp (CyclicSCC ns) = "CSCC" >#< ppBracketsCommas ns++-------------------------------------------------------------------------+-- Building from dpds+-------------------------------------------------------------------------++dpdGrFromEdgesMp :: Ord n => [Map.Map n [n]] -> ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])])+dpdGrFromEdgesMp ns+ = (graphFromEdges es,es)+ where cmbChain = Map.unionWith (++)+ mkEdges = map (\(n,ns) -> (n,n,ns)) . Map.toList+ es = mkEdges . foldr cmbChain Map.empty $ ns++dpdGrFromEdges :: Ord n => [[(n,[n])]] -> ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])])+dpdGrFromEdges+ = dpdGrFromEdgesMp . map Map.fromList++dpdGrFromOrder :: Ord n => [[n]] -> ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])])+dpdGrFromOrder+ = dpdGrFromEdgesMp . map mkChain+ where mkChain = Map.fromList . fst . foldl (\(c,prev) n -> ((n,prev) : c,[n])) ([],[])++mkDpdGr :: Ord n => ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])]) -> DpdGr n+mkDpdGr ((g,n2,v2),es)+ = DpdGr g (transposeG g) es (\v -> let (n,_,ns) = n2 v in (n,ns)) v2++mkDpdGrFromEdgesMp :: Ord n => Map.Map n [n] -> DpdGr n+mkDpdGrFromEdgesMp+ = mkDpdGr . dpdGrFromEdgesMp . (:[])++mkDpdGrFromEdges :: Ord n => [(n,[n])] -> DpdGr n+mkDpdGrFromEdges+ = mkDpdGr . dpdGrFromEdges . (:[])++mkDpdGrFromEdgesMpWithMissing :: Ord n => [n] -> Map.Map n [n] -> DpdGr n+mkDpdGrFromEdgesMpWithMissing missing+ = mkDpdGrFromEdgesMp+ . (Map.fromList [(n,[n]) | n <- missing] `Map.union`)++mkDpdGrFromEdgesMpPadMissing :: Ord n => Map.Map n [n] -> DpdGr n+mkDpdGrFromEdgesMpPadMissing m+ = mkDpdGrFromEdgesMpWithMissing [ n | ns <- Map.elems m, n <- ns, not (Map.member n m) ] m++mkDpdGrFromOrderWithMissing :: Ord n => [n] -> [[n]] -> DpdGr n+mkDpdGrFromOrderWithMissing missing+ = mkDpdGr . dpdGrFromOrder+ . ([[n] | n <- missing] ++)++mkDpdGrFromAssocWithMissing :: Ord n => [n] -> [(n,n)] -> DpdGr n+mkDpdGrFromAssocWithMissing missing+ = mkDpdGr . dpdGrFromEdges+ . map (\(n1,n2) -> [(n1,[n2])])+ . ([(n,n) | n <- missing] ++)++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++dgVsToNs :: DpdGr n -> [Vertex] -> [n]+dgVsToNs g = map (\v -> fst (dgV2N g v))++-------------------------------------------------------------------------+-- Derived info+-------------------------------------------------------------------------++dgTopSort :: DpdGr n -> [n]+dgTopSort g = dgVsToNs g . topSort . dgGr $ g++dgVertices :: Ord n => DpdGr n -> Set.Set n+dgVertices g = Set.fromList . dgVsToNs g . vertices . dgGr $ g++dgReachable :: Ord n => (DpdGr n -> Graph) -> DpdGr n -> n -> Set.Set n+dgReachable gOf g n+ = case dgK2V g n of+ Just n' -> Set.fromList . dgVsToNs g $ reachable (gOf g) n'+ Nothing -> Set.empty++dgReachableFrom :: Ord n => DpdGr n -> n -> Set.Set n+dgReachableFrom = dgReachable dgGr ++dgReachableTo :: Ord n => DpdGr n -> n -> Set.Set n+dgReachableTo = dgReachable dgGrT ++dgDpdsOn :: DpdGr n -> n -> [n]+dgDpdsOn g n = maybe [] (snd . dgV2N g) (dgK2V g n)++dgIsFirst :: Ord n => DpdGr n -> n -> Set.Set n -> Bool+dgIsFirst g n ns+ = Set.null s+ where s = Set.delete n ns `Set.difference` dgReachableTo g n++-------------------------------------------------------------------------+-- SCC+-------------------------------------------------------------------------++dgSCC :: Ord n => DpdGr n -> [SCC n]+dgSCC g = stronglyConnComp . dgEdges $ g++dgSCCToList :: Ord n => DpdGr n -> [[n]]+dgSCCToList = map (flattenSCC) . dgSCC++dgSCCMutuals :: Ord n => DpdGr n -> [[n]]+dgSCCMutuals g = [ ns | (CyclicSCC ns@(_:_:_)) <- dgSCC g ]++dgCheckSCCMutuals :: (Ord n,PP n) => ([PP_Doc] -> err) -> DpdGr n -> [err]+dgCheckSCCMutuals mk g+ = if null ns then [] else [mk $ map pp $ concat $ ns]+ where ns = dgSCCMutuals g+
+ src/UHC/Util/FPath.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module UHC.Util.FPath+ ( FPath(..), fpathSuff+ , FPATH(..)+ , FPathError -- (..)+ , emptyFPath+ -- , mkFPath+ , fpathFromStr+ , mkFPathFromDirsFile+ , fpathToStr, fpathIsEmpty+ , fpathSetBase, fpathSetSuff, fpathSetDir+ , fpathUpdBase+ , fpathRemoveSuff, fpathRemoveDir++ , fpathIsAbsolute++ , fpathAppendDir, fpathUnAppendDir+ , fpathPrependDir, fpathUnPrependDir+ , fpathSplitDirBy+ , mkTopLevelFPath++ , fpathDirSep, fpathDirSepChar++ , fpathOpenOrStdin, openFPath++ , SearchPath+ , FileSuffixes, FileSuffix+ , mkInitSearchPath, searchPathFromFPath, searchPathFromFPaths+ , searchPathFromString+ , searchFPathFromLoc+ , searchLocationsForReadableFiles, searchPathForReadableFiles, searchPathForReadableFile++ , fpathEnsureExists++ , filePathMkPrefix, filePathUnPrefix+ , filePathCoalesceSeparator+ , filePathMkAbsolute, filePathUnAbsolute+ )+where++import Data.Maybe+import Data.List+import Control.Monad+import System.IO+import System.Directory++import UHC.Util.Utils++-------------------------------------------------------------------------------------------+-- Making prefix and inverse, where a prefix has a tailing '/'+-------------------------------------------------------------------------------------------++filePathMkPrefix :: String -> String+filePathMkPrefix d@(_:_) | last d /= '/' = d ++ "/"+filePathMkPrefix d = d++filePathUnPrefix :: String -> String+filePathUnPrefix d | isJust il && l == '/' = filePathUnPrefix i+ where il = initlast d+ (i,l) = fromJust il+filePathUnPrefix d = d++filePathCoalesceSeparator :: String -> String+filePathCoalesceSeparator ('/':d@('/':_)) = filePathCoalesceSeparator d+filePathCoalesceSeparator (c:d) = c : filePathCoalesceSeparator d+filePathCoalesceSeparator d = d++-------------------------------------------------------------------------------------------+-- Making into absolute path and inverse, where absolute means a heading '/'+-------------------------------------------------------------------------------------------++filePathMkAbsolute :: String -> String+filePathMkAbsolute d@('/':_ ) = d+filePathMkAbsolute d = "/" ++ d++filePathUnAbsolute :: String -> String+filePathUnAbsolute d@('/':d') = filePathUnAbsolute d'+filePathUnAbsolute d = d++-------------------------------------------------------------------------------------------+-- File path+-------------------------------------------------------------------------------------------++data FPath+ = FPath+ { fpathMbDir :: !(Maybe String)+ , fpathBase :: !String+ , fpathMbSuff :: !(Maybe String)+ }+ deriving (Show,Eq,Ord)++emptyFPath :: FPath+emptyFPath+ = mkFPath ""++fpathIsEmpty :: FPath -> Bool+fpathIsEmpty fp = null (fpathBase fp)++fpathToStr :: FPath -> String+fpathToStr fpath+ = let adds f = maybe f (\s -> f ++ "." ++ s) (fpathMbSuff fpath)+ addd f = maybe f (\d -> d ++ fpathDirSep ++ f) (fpathMbDir fpath)+ in addd . adds . fpathBase $ fpath++-------------------------------------------------------------------------------------------+-- Observations+-------------------------------------------------------------------------------------------++-- TBD. does not work under WinXX, use FilePath library+fpathIsAbsolute :: FPath -> Bool+fpathIsAbsolute fp+ = case fpathMbDir fp of+ Just ('/':_) -> True+ _ -> False++-------------------------------------------------------------------------------------------+-- Utilities, (de)construction+-------------------------------------------------------------------------------------------++fpathFromStr :: String -> FPath+fpathFromStr fn+ = FPath d b' s+ where (d ,b) = maybe (Nothing,fn) (\(d,b) -> (Just d,b)) (splitOnLast fpathDirSepChar fn)+ (b',s) = maybe (b,Nothing) (\(b,s) -> (b,Just s)) (splitOnLast '.' b )++fpathDirFromStr :: String -> FPath+fpathDirFromStr d = emptyFPath {fpathMbDir = Just d}++fpathSuff :: FPath -> String+fpathSuff = maybe "" id . fpathMbSuff++fpathSetBase :: String -> FPath -> FPath+fpathSetBase s fp+ = fp {fpathBase = s}++fpathUpdBase :: (String -> String) -> FPath -> FPath+fpathUpdBase u fp+ = fp {fpathBase = u (fpathBase fp)}++fpathSetSuff :: String -> FPath -> FPath+fpathSetSuff "" fp+ = fpathRemoveSuff fp+fpathSetSuff s fp+ = fp {fpathMbSuff = Just s}++fpathSetNonEmptySuff :: String -> FPath -> FPath+fpathSetNonEmptySuff "" fp+ = fp+fpathSetNonEmptySuff s fp+ = fp {fpathMbSuff = Just s}++fpathSetDir :: String -> FPath -> FPath+fpathSetDir "" fp+ = fpathRemoveDir fp+fpathSetDir d fp+ = fp {fpathMbDir = Just d}++fpathSplitDirBy :: String -> FPath -> Maybe (String,String)+fpathSplitDirBy byDir fp+ = do { d <- fpathMbDir fp+ ; dstrip <- stripPrefix byDir' d+ ; return (byDir',filePathUnAbsolute dstrip)+ }+ where byDir' = filePathUnPrefix byDir++fpathPrependDir :: String -> FPath -> FPath+fpathPrependDir "" fp+ = fp+fpathPrependDir d fp+ = maybe (fpathSetDir d fp) (\fd -> fpathSetDir (d ++ fpathDirSep ++ fd) fp) (fpathMbDir fp)++fpathUnPrependDir :: String -> FPath -> FPath+fpathUnPrependDir d fp+ = case fpathSplitDirBy d fp of+ Just (_,d) -> fpathSetDir d fp+ _ -> fp++fpathAppendDir :: FPath -> String -> FPath+fpathAppendDir fp ""+ = fp+fpathAppendDir fp d+ = maybe (fpathSetDir d fp) (\fd -> fpathSetDir (fd ++ fpathDirSep ++ d) fp) (fpathMbDir fp)++-- remove common trailing part of dir+fpathUnAppendDir :: FPath -> String -> FPath+fpathUnAppendDir fp ""+ = fp+fpathUnAppendDir fp d+ = case fpathMbDir fp of+ Just p -> fpathSetDir (filePathUnPrefix prefix) fp+ where (prefix,_) = splitAt (length p - length d) p+ _ -> fp++fpathRemoveSuff :: FPath -> FPath+fpathRemoveSuff fp+ = fp {fpathMbSuff = Nothing}++fpathRemoveDir :: FPath -> FPath+fpathRemoveDir fp+ = fp {fpathMbDir = Nothing}++splitOnLast :: Char -> String -> Maybe (String,String)+splitOnLast splitch fn+ = case fn of+ "" -> Nothing+ (f:fs) -> let rem = splitOnLast splitch fs+ in if f == splitch+ then maybe (Just ("",fs)) (\(p,s)->Just (f:p,s)) rem+ else maybe Nothing (\(p,s)->Just (f:p,s)) rem++mkFPathFromDirsFile :: Show s => [s] -> s -> FPath+mkFPathFromDirsFile dirs f+ = fpathSetDir (concat $ intersperse fpathDirSep $ map show $ dirs) (mkFPath (show f))++mkTopLevelFPath :: String -> String -> FPath+mkTopLevelFPath suff fn+ = let fpNoSuff = mkFPath fn+ in maybe (fpathSetSuff suff fpNoSuff) (const fpNoSuff) . fpathMbSuff $ fpNoSuff++-------------------------------------------------------------------------------------------+-- Config+-------------------------------------------------------------------------------------------++fpathDirSep :: String+fpathDirSep = "/"++fpathDirSepChar :: Char+fpathDirSepChar = head fpathDirSep++-------------------------------------------------------------------------------------------+-- Class 'can make FPath of ...'+-------------------------------------------------------------------------------------------++class FPATH f where+ mkFPath :: f -> FPath++instance FPATH String where+ mkFPath = fpathFromStr++instance FPATH FPath where+ mkFPath = id++-------------------------------------------------------------------------------------------+-- Class 'is error related to FPath'+-------------------------------------------------------------------------------------------++class FPathError e++instance FPathError String++-------------------------------------------------------------------------------------------+-- Open path for read or return stdin+-------------------------------------------------------------------------------------------++fpathOpenOrStdin :: FPath -> IO (FPath,Handle)+fpathOpenOrStdin fp+ = if fpathIsEmpty fp+ then return (mkFPath "<stdin>",stdin)+ else do { let fn = fpathToStr fp+ ; h <- openFile fn ReadMode+ ; return (fp,h)+ }++openFPath :: FPath -> IOMode -> Bool -> IO (String, Handle)+openFPath fp mode binary+ | fpathIsEmpty fp = case mode of+ ReadMode -> return ("<stdin>" ,stdin )+ WriteMode -> return ("<stdout>",stdout)+ AppendMode -> return ("<stdout>",stdout)+ ReadWriteMode -> error "cannot use stdin/stdout with random access"+ | otherwise = do { let fNm = fpathToStr fp+ ; h <- if binary+ then openBinaryFile fNm mode+ else openFile fNm mode+ ; return (fNm,h)+ }++-------------------------------------------------------------------------------------------+-- Directory+-------------------------------------------------------------------------------------------++fpathEnsureExists :: FPath -> IO ()+fpathEnsureExists fp+ = do { let d = fpathMbDir fp+ ; when (isJust d) (createDirectoryIfMissing True (fromJust d))+ }++-------------------------------------------------------------------------------------------+-- Search path utils+-------------------------------------------------------------------------------------------++type SearchPath = [String]+type FileSuffix = Maybe String+type FileSuffixes = [FileSuffix]++searchPathFromFPaths :: [FPath] -> SearchPath+searchPathFromFPaths fpL = nub [ d | (Just d) <- map fpathMbDir fpL ] ++ [""]++searchPathFromFPath :: FPath -> SearchPath+searchPathFromFPath fp = searchPathFromFPaths [fp]++mkInitSearchPath :: FPath -> SearchPath+mkInitSearchPath = searchPathFromFPath++searchPathFromString :: String -> [String]+searchPathFromString+ = unfoldr f+ where f "" = Nothing+ f sp = Just (break (== ';') sp)++-- Simple function that returns a particular file under a+-- certain root dir.+searchFPathFromLoc :: FilePath -> FPath -> [(FilePath,FPath)]+searchFPathFromLoc loc fp = [(loc,fpathPrependDir loc fp)]++searchLocationsForReadableFiles :: FPathError e => (loc -> FPath -> [(loc,FPath,[e])]) -> Bool -> [loc] -> FileSuffixes -> FPath -> IO [(FPath,loc,[e])]+searchLocationsForReadableFiles 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 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)]+ else return []+ }+ tryToOpenWithSuffs suffs (loc,fp,x)+ = fmap (map (tup12to123 x)) $+ case suffs of+ [] -> tryToOpen loc Nothing fp+ _ -> select stopAtFirst+ (\(ms,f) -> tryToOpen loc ms f)+ ({- (Nothing,fp) : -} zipWith (\s f -> (s,f)) suffs (repeat fp))+ 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+ = fmap (map tup123to1) $ searchLocationsForReadableFiles (\s f -> map (tup12to123 ([]::[String])) $ searchFPathFromLoc s f) stopAtFirst locs suffs fp++searchPathForReadableFile :: SearchPath -> FileSuffixes -> FPath -> IO (Maybe FPath)+searchPathForReadableFile paths suffs fp+ = do fs <- searchPathForReadableFiles True paths suffs fp+ return (listToMaybe fs)+
+ src/UHC/Util/FastSeq.hs view
@@ -0,0 +1,118 @@+module UHC.Util.FastSeq+ ( FastSeq((:++:),(::+:),(:+::))+ , Seq+ , isEmpty, null+ , empty+ , size+ , singleton+ , toList, fromList+ , map+ , union, unions+ , firstNotEmpty+ )+ where++import Prelude hiding (null,map)+import qualified Data.List as L+import qualified UHC.Util.Utils as U++-------------------------------------------------------------------------+-- Fast sequence, i.e. delayed concat 'trick'+-------------------------------------------------------------------------++infixr 5 :++:, :+::+infixl 5 ::+:++data FastSeq a+ = !(FastSeq a) :++: !(FastSeq a)+ | !a :+:: !(FastSeq a)+ | !(FastSeq a) ::+: !a+ | FSeq !a+ | FSeqL ![a]+ | FSeqNil++type Seq a = FastSeq a++empty :: FastSeq a+empty = FSeqNil++-------------------------------------------------------------------------+-- Observations+-------------------------------------------------------------------------++isEmpty, null :: FastSeq a -> Bool+isEmpty FSeqNil = True+isEmpty (FSeqL x ) = L.null x+isEmpty (FSeq _ ) = False+isEmpty (x1 :++: x2) = isEmpty x1 && isEmpty x2+isEmpty (x1 :+:: x2) = False+isEmpty (x1 ::+: x2) = False+-- isEmpty sq = L.null $ toList sq++null = isEmpty++size :: FastSeq a -> Int+size FSeqNil = 0+size (FSeqL x ) = length x+size (FSeq _ ) = 1+size (x1 :++: x2) = size x1 + size x2+size (x1 :+:: x2) = 1 + size x2+size (x1 ::+: x2) = size x1 + 1++-------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------++singleton :: a -> FastSeq a+singleton = FSeq++-------------------------------------------------------------------------+-- Conversion+-------------------------------------------------------------------------++fromList :: [a] -> FastSeq a+fromList [] = FSeqNil+fromList l = FSeqL l++toList :: FastSeq a -> [a]+toList s+ = a s []+ where a FSeqNil l = l+ a (FSeq x ) l = x : l+ a (FSeqL x ) l = x L.++ l+ a (x1 :++: x2) l = a x1 (a x2 l)+ a (x1 :+:: x2) l = x1 : a x2 l+ a (x1 ::+: x2) l = a x1 (x2 : l)++-------------------------------------------------------------------------+-- Map, ...+-------------------------------------------------------------------------++map :: (a->b) -> FastSeq a -> FastSeq b+map f FSeqNil = FSeqNil+map f (FSeq x ) = FSeq $ f x+map f (FSeqL x ) = FSeqL $ L.map f x+map f (x1 :++: x2) = map f x1 :++: map f x2+map f (x1 :+:: x2) = f x1 :+:: map f x2+map f (x1 ::+: x2) = map f x1 ::+: f x2++-------------------------------------------------------------------------+-- Union+-------------------------------------------------------------------------++union :: FastSeq a -> FastSeq a -> FastSeq a+union FSeqNil FSeqNil = FSeqNil+union FSeqNil s2 = s2+union s1 FSeqNil = s1+union s1 s2 = s1 :++: s2++unions :: [FastSeq a] -> FastSeq a+unions [s] = s+unions s = L.foldr ( (:++:)) FSeqNil s++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++firstNotEmpty :: [FastSeq x] -> FastSeq x+firstNotEmpty = U.maybeHd empty id . filter (not . isEmpty)
+ src/UHC/Util/Nm.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module UHC.Util.Nm+where++import Data.Maybe+import Data.Char+import Data.List+import UHC.Util.Pretty+import UHC.Util.FPath(FPATH(mkFPath))+import UHC.Util.Utils++-------------------------------------------------------------------------+-- Names (for use in Shuffle, Ruler)+-------------------------------------------------------------------------++data Nm' s+ = NmEmp+ | Nm { nmStr :: s }+ | NmSel { nmNm :: Nm' s+ , nmMbSel :: Maybe s+ }+ | NmQual { nmNm :: Nm' s+ , nmQual :: s+ }+ deriving (Eq,Ord)++type Nm = Nm' String++nmSelSep, nmQualSep :: String+nmSelSep = "."+nmQualSep = "_"++nmBase' :: Nm -> String+nmBase' (NmSel n _) = nmBase' n+nmBase' (Nm s) = s+nmBase' NmEmp = ""++nmBase :: Nm -> Nm+nmBase = Nm . nmBase'++nmSetSuff :: Nm -> String -> Nm+nmSetSuff n s = NmSel (nmBase n) (Just s)++nmSetBase :: Nm -> String -> Nm+nmSetBase n s+ = nmFromMbL (Just s:nL)+ where (_:nL) = nmToMbL n++nmSetSel :: Nm' s -> s -> Nm' s+nmSetSel n s = NmSel n (Just s)++nmSel :: Nm -> String+nmSel = maybe "" id . nmMbSel++nmInit :: Nm -> Nm+nmInit (NmSel n _) = n+nmInit n = n++nmToMbL :: Nm' s -> [Maybe s]+nmToMbL + = reverse . ns+ where ns (NmSel n s) = s : ns n+ ns (Nm s) = [Just s]+ ns NmEmp = []++nmToL :: Nm -> [String]+nmToL = map (maybe "" id) . nmToMbL++nmFromMbL :: [Maybe s] -> Nm' s+nmFromMbL+ = n . reverse+ where n [Just s] = Nm s+ n (s:ss) = NmSel (n ss) s+ n [] = NmEmp++nmFromL :: [s] -> Nm' s+nmFromL = nmFromMbL . map Just++nmApd :: Nm' s -> Nm' s -> Nm' s+nmApd n1 n2+ = nmFromMbL (l1 ++ l2)+ where l1 = nmToMbL n1+ l2 = nmToMbL n2++nmApdL :: [Nm' s] -> Nm' s+nmApdL+ = nmFromMbL . concat . map nmToMbL++nmStrApd :: Nm -> Nm -> Nm+nmStrApd n1 n2+ = Nm (s1 ++ s2)+ where s1 = show n1+ s2 = show n2++nmCapitalize :: Nm -> Nm+nmCapitalize n+ = case nmToMbL n of+ (Just s:ns) -> nmFromMbL (Just (strCapitalize s) : ns)+ _ -> n++nmDashed :: Nm -> Nm+nmDashed = Nm . map (\c -> if isAlphaNum c then c else '-') . show++nmFlatten :: Nm -> Nm+nmFlatten = Nm . show++nmShow' :: String -> Nm -> String+nmShow' sep = concat . intersperse sep . nmToL++nmShowAG :: Nm -> String+nmShowAG = nmShow' "_"++instance Show Nm where+ show = nmShow' nmSelSep++instance PP Nm where+ pp = ppListSep "" "" nmSelSep . nmToL++instance Functor Nm' where+ fmap f NmEmp = NmEmp+ fmap f (Nm s) = Nm (f s)+ fmap f (NmSel n ms) = NmSel (fmap f n) (fmap f ms)+ fmap f (NmQual n s) = NmQual (fmap f n) ( f s)++-------------------------------------------------------------------------+-- Make name of something+-------------------------------------------------------------------------++class NM a where+ mkNm :: a -> Nm++instance NM Nm where+ mkNm = id++instance NM String where+ mkNm s = nmFromL [s]++instance NM Int where+ mkNm = mkNm . show++-------------------------------------------------------------------------+-- Make FPath of Nm+-------------------------------------------------------------------------++instance FPATH Nm where+ mkFPath = mkFPath . show
+ src/UHC/Util/ParseErrPrettyPrint.hs view
@@ -0,0 +1,52 @@+module UHC.Util.ParseErrPrettyPrint+ ( ppPos, ppErr, ppWarn+ , ppTr+ )+ where++import Data.List+import UHC.Util.Pretty+import UU.Parsing+import UU.Scanner.Position( noPos, Pos, Position(..) )++-------------------------------------------------------------------------+-- PP of parse errors+-------------------------------------------------------------------------++ppPos :: Position p => p -> PP_Doc+ppPos p+ = if l < 0 then empty else pp f >|< ppListSep "(" ")" "," [pp l,pp c]+ where l = line p+ c = column p+ f = file p++ppMsg :: Position pos => String -> (String,pos) -> PP_Doc -> PP_Doc+ppMsg what (sym,pos) p+ = "***" >#< what >#< "***"+ >-< (if l > 0 && not (null sym)+ then ppPos pos >#< s >|< ":"+ else if l > 0+ then ppPos pos >|< ":"+ else if not (null sym)+ then s >|< ":"+ else empty+ )+ >-< indent 4 p+ where s = "at symbol '" >|< pp sym >|< "'"+ l = line pos++ppErr, ppWarn :: Position pos => (String,pos) -> PP_Doc -> PP_Doc+ppErr = ppMsg "ERROR"+ppWarn = ppMsg "WARNING"++ppTr :: PP_Doc -> PP_Doc+ppTr = ppMsg "TRACE" ("",noPos)++instance (Eq s, Show s, Show p, Position p) => PP (Message s p) where+ pp (Msg expecting position action) + = ppErr ("",position)+ ( "Expecting :" >#< (hlist $ intersperse (pp " ") $ map pp $ showExp)+ >#< (if null omitExp then empty else pp "...")+ >-< "Repaired by:" >#< show action+ )+ where (showExp,omitExp) = splitAt 20 . words $ show expecting
+ src/UHC/Util/ParseUtils.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE RankNTypes, FlexibleContexts #-}++module UHC.Util.ParseUtils+ ( PlainParser+ , LayoutParser, LayoutParser2+ + , parsePlain+ , parseOffsideToResMsgs+ , parseToResMsgs+ + , parseOffsideToResMsgsStopAtErr+ + , pAnyFromMap, pAnyKey+ , pMaybe, pMb+ + , pDo+ )+ where++import qualified Data.Map as Map+import Data.Maybe+import UU.Parsing+import UU.Parsing.Machine+import UU.Parsing.Offside+import UU.Scanner.Position( Position(..) )++-------------------------------------------------------------------------+-- Type(s) of parsers+-------------------------------------------------------------------------++type LayoutParser tok ep+ = (IsParser (OffsideParser i o tok p) tok,InputState i tok p, OutputState o, Position p)+ => OffsideParser i o tok p ep++type LayoutParser2 tok ep+ = (IsParser (OffsideParser i o tok p) tok,InputState i tok p, OutputState o, Position p)+ => OffsideParser i o tok p ep -> OffsideParser i o tok p ep++type PlainParser tok gp = IsParser p tok => p gp++-------------------------------------------------------------------------+-- Parsing utils+-------------------------------------------------------------------------++valFromPair :: Steps (Pair a (Pair a1 r)) s p -> Steps (a, a1) s p+valFromPair p+ = val fromPair p+ where fromPair (Pair x (Pair y _)) = (x,y)++toResMsgs :: Steps (Pair a r) s pos -> (a, [Message s pos])+toResMsgs steps+ = (r,getMsgs steps)+ where (Pair r _) = evalSteps steps++toOffsideResMsgs :: Steps (a,b) s pos -> (a, [Message s pos])+toOffsideResMsgs steps+ = r `seq` (r,getMsgs steps)+ where (r,_) = evalSteps steps++parsePlain :: (Symbol s, InputState inp s pos) + => AnaParser inp Pair s pos a + -> inp + -> Steps (a, inp) s pos+parsePlain p inp+ = valFromPair (parse p inp)++parseToResMsgs :: (Symbol s,InputState inp s pos) => AnaParser inp Pair s pos a -> inp -> (a,[Message s pos])+parseToResMsgs p inp+ = toResMsgs (parse p inp)++parseOffsideToResMsgs+ :: (Symbol s, InputState i s p, Position p)+ => OffsideParser i Pair s p a -> OffsideInput i s p -> (a,[Message (OffsideSymbol s) p])+parseOffsideToResMsgs p inp+ = toOffsideResMsgs (parseOffside p inp)++-------------------------------------------------------------------------+-- Parsing, stopping at first error+-------------------------------------------------------------------------++handleEofStopAtErr input+ = case splitStateE input+ of Left' s ss -> NoMoreSteps (Pair ss ())+ Right' ss -> NoMoreSteps (Pair ss ())++parseStopAtErr+ :: (Symbol s, InputState inp s pos) + => AnaParser inp Pair s pos a + -> inp + -> Steps (Pair a (Pair inp ())) s pos+parseStopAtErr+ = parsebasic handleEofStopAtErr++parseOffsideStopAtErr+ :: (Symbol s, InputState i s p, Position p) + => OffsideParser i Pair s p a + -> OffsideInput i s p+ -> Steps (a, OffsideInput i s p) (OffsideSymbol s) p+parseOffsideStopAtErr (OP p) inp+ = valFromPair (parseStopAtErr p inp)++parseOffsideToResMsgsStopAtErr+ :: (Symbol s, InputState i s p, Position p) =>+ OffsideParser i Pair s p a+ -> OffsideInput i s p+ -> (a, [Message (OffsideSymbol s) p])+parseOffsideToResMsgsStopAtErr p inp+ = toOffsideResMsgs (parseOffsideStopAtErr p inp)++-------------------------------------------------------------------------+-- Offside for 'do' notation.+-- Problem tackled here is that both do statements and the last expr may start with 'let x=e',+-- and the presence of 'in e' following 'let x=e' indicates that it is the last statement.+-- This is a variation of pBlock1.+-------------------------------------------------------------------------++pDo :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) + => OffsideParser i o s p x + -> OffsideParser i o s p y + -> OffsideParser i o s p z + -> OffsideParser i o s p a + -> OffsideParser i o s p (Maybe last -> a)+ -> OffsideParser i o s p last + -> OffsideParser i o s p [a]+pDo open sep close pPlain pLastPrefix pLastRest+ = pOffside open close explicit implicit+ where sep' = () <$ sep+ elems s = sep0 *> es <* sep0+ where es = (:) <$> pPlain <*> esTail+ <|> (pLastPrefix+ <**> ( (\r pre -> [pre (Just r)]) <$> pLastRest+ <|> (\tl pre -> pre Nothing : tl) <$> esTail+ )+ )+ esTail = pList1 s *> es <|> pSucceed []+ sep0 = pList s+ explicit = elems sep'+ implicit = elems (sep' <|> pSeparator)++{-+pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) + => OffsideParser i o s p x + -> OffsideParser i o s p y + -> OffsideParser i o s p z + -> OffsideParser i o s p a + -> OffsideParser i o s p [a]+pBlock1 open sep close p = pOffside open close explicit implicit+ where sep' = () <$ sep+ elems s = pList s *> pList1Sep (pList1 s) p <* pList s+ explicit = elems sep'+ implicit = elems (sep' <|> pSeparator)++-}++-------------------------------------------------------------------------+-- Misc combinators+-------------------------------------------------------------------------++-- parse possibly present p+pMaybe :: (IsParser p s) => a1 -> (a -> a1) -> p a -> p a1+pMaybe n j p = j <$> p <|> pSucceed n++pAnyKey :: (IsParser p s) => (a1 -> p a) -> [a1] -> p a+pAnyKey pKey = foldr1 (<|>) . map pKey++pMb :: (IsParser p s) => p a -> p (Maybe a)+pMb = pMaybe Nothing Just++-- given (non-empty) key->value map, return parser for all keys returning corresponding value+pAnyFromMap :: (IsParser p s) => (k -> p a1) -> Map.Map k v -> p v+pAnyFromMap pKey m = foldr1 (<|>) [ v <$ pKey k | (k,v) <- Map.toList m ]+
+ src/UHC/Util/Pretty.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE RankNTypes #-}++-------------------------------------------------------------------------+-- Wrapper module around pretty printing+-------------------------------------------------------------------------++module UHC.Util.Pretty+ ( -- module UU.Pretty+ -- module UHC.Util.Chitil.Pretty+ module UHC.Util.PrettySimple++ , PP_DocL++ , ppListSep, ppListSepV, ppListSepVV+ , ppBlock, ppBlock'+ , ppCommas, ppCommas'+ , ppSemis, ppSemis'+ , ppSpaces+ , ppCurlys+ , ppCurlysBlock+ , ppCurlysSemisBlock+ , ppCurlysCommasBlock+ , ppCurlysCommas, ppCurlysCommas', ppCurlysCommasWith+ , ppCurlysSemis, ppCurlysSemis'+ , ppParensCommas, ppParensCommas'+ , ppParensSemisBlock+ , ppParensCommasBlock+ , ppBrackets+ , ppBracketsCommas, ppBracketsCommas', ppBracketsCommasV+ , ppHorizontally, ppVertically+ , ppListSepFill++ , ppPacked, ppParens, ppCurly, ppVBar++ , ppDots, ppMb, ppUnless, ppWhen++ , hPutWidthPPLn, putWidthPPLn+ , hPutPPLn, putPPLn+ , hPutPPFile, putPPFile+ , putPPFPath+ )+ where++-- import UU.Pretty+-- import UHC.Util.Chitil.Pretty+import UHC.Util.PrettySimple+import UHC.Util.FPath+import System.IO+import Data.List++-------------------------------------------------------------------------+-- PP utils for lists+-------------------------------------------------------------------------++type PP_DocL = [PP_Doc]++ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c+{-+ppListSep o c s pps+ = o >|< l pps >|< c+ where l [] = empty+ l [p] = pp p+ l (p:ps) = pp p >|< map (s >|<) ps+-}++ppListSepWith :: (PP s, PP c, PP o) => o -> c -> s -> (a->PP_Doc) -> [a] -> PP_Doc+ppListSepWith o c s ppa pps = o >|< hlist (intersperse (pp s) (map ppa pps)) >|< c++ppBlock' :: (PP ocs,PP a) => ocs -> ocs -> ocs -> [a] -> [PP_Doc]+ppBlock' o c s [] = [o >|< c]+ppBlock' o c s [a] = [o >|< a >|< c]+ppBlock' o c s (a:as) = [o >|< a] ++ map (s >|<) as ++ [pp c]++ppBlock :: (PP ocs,PP a) => ocs -> ocs -> ocs -> [a] -> PP_Doc+ppBlock o c s = vlist . ppBlock' o c s++ppCommas :: PP a => [a] -> PP_Doc+ppCommas = ppListSep "" "" ","++ppCommas' :: PP a => [a] -> PP_Doc+ppCommas' = ppListSep "" "" ", "++ppSemis :: PP a => [a] -> PP_Doc+ppSemis = ppListSep "" "" ";"++ppSemis' :: PP a => [a] -> PP_Doc+ppSemis' = ppListSep "" "" "; "++ppSpaces :: PP a => [a] -> PP_Doc+ppSpaces = ppListSep "" "" " "++ppCurlysBlock :: PP a => [a] -> PP_Doc+ppCurlysBlock = ppBlock "{ " "}" " " . map pp++ppCurlysSemisBlock :: PP a => [a] -> PP_Doc+ppCurlysSemisBlock = ppBlock "{ " "}" "; " . map pp++ppCurlysCommasBlock :: PP a => [a] -> PP_Doc+ppCurlysCommasBlock = ppBlock "{ " "}" ", " . map pp++ppParensSemisBlock :: PP a => [a] -> PP_Doc+ppParensSemisBlock = ppBlock "( " ")" "; " . map pp++ppParensCommasBlock :: PP a => [a] -> PP_Doc+ppParensCommasBlock = ppBlock "( " ")" ", " . map pp++ppBracketsCommas :: PP a => [a] -> PP_Doc+ppBracketsCommas = ppListSep "[" "]" ","++ppBracketsCommasV :: PP a => [a] -> PP_Doc+ppBracketsCommasV = ppListSepV3 "[ " "]" ", "++ppBracketsCommas' :: PP a => [a] -> PP_Doc+ppBracketsCommas' = ppListSep "[" "]" ", "++ppParensCommas :: PP a => [a] -> PP_Doc+ppParensCommas = ppListSep "(" ")" ","++ppParensCommas' :: PP a => [a] -> PP_Doc+ppParensCommas' = ppListSep "(" ")" ", "++ppCurlysCommas :: PP a => [a] -> PP_Doc+ppCurlysCommas = ppListSep "{" "}" ","++ppCurlysCommasWith :: PP a => (a->PP_Doc) -> [a] -> PP_Doc+ppCurlysCommasWith = ppListSepWith "{" "}" ","++ppCurlysCommas' :: PP a => [a] -> PP_Doc+ppCurlysCommas' = ppListSep "{" "}" ", "++ppCurlysSemis :: PP a => [a] -> PP_Doc+ppCurlysSemis = ppListSep "{" "}" ";"++ppCurlysSemis' :: PP a => [a] -> PP_Doc+ppCurlysSemis' = ppListSep "{" "}" "; "++{-+ppCommaListV :: PP a => [a] -> PP_Doc+ppCommaListV = ppListSepVV "[" "]" "; "+-}++ppListSepV' :: (PP s, PP c, PP o, PP a) => (forall x y . (PP x, PP y) => x -> y -> PP_Doc) -> o -> c -> s -> [a] -> PP_Doc+ppListSepV' aside o c s pps+ = l pps+ where l [] = o `aside` c+ l [p] = o `aside` p `aside` c+ l (p:ps) = vlist ([o `aside` p] ++ map (s `aside`) (init ps) ++ [s `aside` last ps `aside` c])++-- compact vertical list+ppListSepV3 :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSepV3 o c s pps+ = l pps+ where l [] = o >|< c+ l [p] = o >|< p >|< c+ l (p:ps) = vlist ([o >|< p] ++ map (s >|<) (init ps) ++ [s >|< last ps >|< c])+{-+-}++ppListSepV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSepV = ppListSepV' (>|<)++ppListSepVV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSepVV = ppListSepV' (>-<)++{-+ppListSepV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSepV o c s pps+ = l pps+ where l [] = o >|< c+ l [p] = ppPacked o c p+ l (p:ps) = vlist ([o >|< p] ++ map (s >|<) (init ps) ++ [s >|< last ps >|< c])++ppListSepVV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSepVV o c s pps+ = o >-< foldr (\l r -> l >-< s >-< r) empty pps >-< c+-}++ppVertically :: [PP_Doc] -> PP_Doc+ppVertically = vlist++ppHorizontally :: [PP_Doc] -> PP_Doc+ppHorizontally = hlist++ppListSepFill :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSepFill o c s pps+ = l pps+ where l [] = o >|< c+ l [p] = o >|< pp p >|< c+ l (p:ps) = fill ((o >|< pp p) : map (s >|<) ps) >|< c++-------------------------------------------------------------------------+-- Printing open/close pairs+-------------------------------------------------------------------------++ppPacked :: (PP o, PP c, PP p) => o -> c -> p -> PP_Doc+ppPacked o c pp+ = o >|< pp >|< c++ppParens, ppBrackets, ppCurly, ppCurlys, ppVBar :: PP p => p -> PP_Doc+ppParens = ppPacked "(" ")"+ppBrackets = ppPacked "[" "]"+ppCurly = ppPacked "{" "}"+ppCurlys = ppCurly+ppVBar = ppPacked "|" "| "++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++ppDots :: PP a => [a] -> PP_Doc+ppDots = ppListSep "" "" "."++ppMb :: PP a => Maybe a -> PP_Doc+ppMb = maybe empty pp++ppUnless :: Bool -> PP_Doc -> PP_Doc+ppUnless b p = if b then empty else p++ppWhen :: Bool -> PP_Doc -> PP_Doc+ppWhen b p = if b then p else empty++instance PP a => PP (Maybe a) where+ pp = maybe (pp "?") pp++instance PP Bool where+ pp = pp . show++-------------------------------------------------------------------------+-- PP printing to file+-------------------------------------------------------------------------++hPutLn :: Handle -> Int -> PP_Doc -> IO ()+{-+hPutLn h w pp+ = do hPut h pp w+ hPutStrLn h ""+-}+hPutLn h w pp+ = hPutStrLn h (disp pp w "")++hPutWidthPPLn :: Handle -> Int -> PP_Doc -> IO ()+hPutWidthPPLn h w pp = hPutLn h w pp++putWidthPPLn :: Int -> PP_Doc -> IO ()+putWidthPPLn = hPutWidthPPLn stdout++hPutPPLn :: Handle -> PP_Doc -> IO ()+hPutPPLn h = hPutWidthPPLn h 4000++putPPLn :: PP_Doc -> IO ()+putPPLn = hPutPPLn stdout++hPutPPFile :: Handle -> PP_Doc -> Int -> IO ()+hPutPPFile h pp wid+ = hPutLn h wid pp+++putPPFPath :: FPath -> PP_Doc -> Int -> IO ()+putPPFPath fp pp wid+ = do { fpathEnsureExists fp+ ; putPPFile (fpathToStr fp) pp wid+ }++putPPFile :: String -> PP_Doc -> Int -> IO ()+putPPFile fn pp wid+ = do { h <- openFile fn WriteMode+ ; hPutPPFile h pp wid+ ; hClose h+ }
+ src/UHC/Util/PrettySimple.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TypeSynonymInstances #-}++-------------------------------------------------------------------------+-- Subset of UU.Pretty, based on very simple pretty printing+-------------------------------------------------------------------------++module UHC.Util.PrettySimple+ ( PP_Doc, PP(..)+ , disp+ , hPut++ , (>|<), (>-<)+ , (>#<)+ , hlist, vlist, hv+ , fill+ , indent++{-+ , pp_wrap, pp_quotes, pp_doubleQuotes, pp_parens, pp_brackets, pp_braces+ , ppPacked, ppParens, ppBrackets, ppBraces, ppCurlys+-}++ , empty, text+ )+ where++import System.IO++-------------------------------------------------------------------------+-- Doc structure+-------------------------------------------------------------------------++data Doc+ = Emp+ | Str !String -- basic string+ | Hor Doc !Doc -- horizontal positioning+ | Ver Doc !Doc -- vertical positioning+ | Ind !Int Doc -- indent++type PP_Doc = Doc++-------------------------------------------------------------------------+-- Basic combinators+-------------------------------------------------------------------------++infixr 3 >|<, >#<+infixr 2 >-<++(>|<) :: (PP a, PP b) => a -> b -> PP_Doc+l >|< r = pp l `Hor` pp r++(>-<) :: (PP a, PP b) => a -> b -> PP_Doc+l >-< r = pp l `Ver` pp r -- pp l <$$> pp r++(>#<) :: (PP a, PP b) => a -> b -> PP_Doc+l >#< r = l >|< " " >|< r++indent :: PP a => Int -> a -> PP_Doc+indent i d = Ind i $ pp d++text :: String -> PP_Doc+text = Str++empty :: PP_Doc+empty = Emp++-------------------------------------------------------------------------+-- Derived combinators+-------------------------------------------------------------------------++hlist, vlist :: PP a => [a] -> PP_Doc+vlist [] = empty+vlist as = foldr (>-<) empty as+hlist [] = empty+hlist as = foldr (>|<) empty as++hv :: PP a => [a] -> PP_Doc+hv = vlist++fill :: PP a => [a] -> PP_Doc+fill = hlist++-------------------------------------------------------------------------+-- PP class+-------------------------------------------------------------------------++class Show a => PP a where+ pp :: a -> PP_Doc+ pp = text . show++ ppList :: [a] -> PP_Doc+ ppList as = hlist as++instance PP PP_Doc where+ pp = id++instance PP Char where+ pp c = text [c]+ ppList = text++instance PP a => PP [a] where+ pp = ppList++instance Show PP_Doc where+ show p = disp p 200 ""++instance PP Int where+ pp = text . show++instance PP Float where+ pp = text . show++-------------------------------------------------------------------------+-- Observation+-------------------------------------------------------------------------++isEmpty :: PP_Doc -> Bool+isEmpty Emp = True+isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2+isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2+isEmpty (Ind _ d ) = isEmpty d+isEmpty _ = False++-------------------------------------------------------------------------+-- Rendering+-------------------------------------------------------------------------++disp :: PP_Doc -> Int -> ShowS+disp d _ s+ = r+ where (r,_) = put 0 d s+ put p d s+ = case d of+ Emp -> (s,p)+ Str s' -> (s' ++ s,p + length s')+ Ind i d -> (ind ++ r,p')+ where (r,p') = put (p+i) d s+ ind = replicate i ' '+ Hor d1 d2 -> (r1,p2)+ where (r1,p1) = put p d1 r2+ (r2,p2) = put p1 d2 s+ Ver d1 d2 | isEmpty d1+ -> put p d2 s+ Ver d1 d2 | isEmpty d2+ -> put p d1 s+ Ver d1 d2 -> (r1,p2)+ where (r1,p1) = put p d1 $ "\n" ++ ind ++ r2+ (r2,p2) = put p d2 s+ ind = replicate p ' '++hPut :: Handle -> PP_Doc -> Int -> IO ()+hPut h d _+ = do _ <- put 0 d h+ return ()+ where put p d h+ = case d of+ Emp -> return p+ Str s -> do hPutStr h s+ return $ p + length s+ Ind i d -> do hPutStr h $ replicate i ' '+ put (p+i) d h+ Hor d1 d2 -> do p' <- put p d1 h+ put p' d2 h+ Ver d1 d2 | isEmpty d1+ -> put p d2 h+ Ver d1 d2 | isEmpty d2+ -> put p d1 h+ Ver d1 d2 -> do _ <- put p d1 h+ hPutStr h $ "\n" ++ replicate p ' '+ put p d2 h
+ src/UHC/Util/PrettyUtils.hs view
@@ -0,0 +1,18 @@+module UHC.Util.PrettyUtils where++import UHC.Util.Pretty++-------------------------------------------------------------------------+-- Utils for tools: making LaTeX+-------------------------------------------------------------------------++mkTexCmdDef :: (PP cmd, PP a, PP b) => cmd -> a -> b -> PP_Doc+mkTexCmdDef cmd nm def = "\\" >|< pp cmd >|< "{" >|< pp nm >|< "}{%" >-< pp def >-< "}"++mkTexCmdUse :: (PP cmd, PP a) => cmd -> a -> PP_Doc+mkTexCmdUse cmd nm = "\\" >|< pp cmd >|< "{" >|< pp nm >|< "}"++mkTexCmdUse' :: (PP cmd, PP a) => cmd -> a -> PP_Doc+mkTexCmdUse' cmd nm = mkTexCmdUse cmd nm >|< "%"++
+ src/UHC/Util/Rel.hs view
@@ -0,0 +1,85 @@+module UHC.Util.Rel+ ( Rel+ , empty+ , toList, fromList+ , singleton+ , dom, rng+ , restrictDom, restrictRng+ , mapDom, mapRng+ , partitionDom, partitionRng+ , intersection, difference, union, unions+ , apply+ , toDomMap, toRngMap+ , mapDomRng+ )+ where++import qualified Data.Map as Map+import qualified Data.Set as Set++-------------------------------------------------------------------------+-- Relation+-------------------------------------------------------------------------++type Rel a b = Set.Set (a,b)++toList :: Rel a b -> [(a,b)]+toList = Set.toList++fromList :: (Ord a, Ord b) => [(a,b)] -> Rel a b+fromList = Set.fromList++singleton :: (Ord a, Ord b) => a -> b -> Rel a b+singleton a b = fromList [(a,b)]++empty :: Rel a b+empty = Set.empty++dom :: (Ord a, Ord b) => Rel a b -> Set.Set a+dom = Set.map fst++rng :: (Ord a, Ord b) => Rel a b -> Set.Set b+rng = Set.map snd++restrictDom :: (Ord a, Ord b) => (a -> Bool) -> Rel a b -> Rel a b+restrictDom p = Set.filter (p . fst)++restrictRng :: (Ord a, Ord b) => (b -> Bool) -> Rel a b -> Rel a b+restrictRng p = Set.filter (p . snd)++mapDom :: (Ord a, Ord b, Ord x) => (a -> x) -> Rel a b -> Rel x b+mapDom f = Set.map (\(a,b) -> (f a,b))++mapRng :: (Ord a, Ord b, Ord x) => (b -> x) -> Rel a b -> Rel a x+mapRng f = Set.map (\(a,b) -> (a,f b))++partitionDom :: (Ord a, Ord b) => (a -> Bool) -> Rel a b -> (Rel a b,Rel a b)+partitionDom f = Set.partition (f . fst)++partitionRng :: (Ord a, Ord b) => (b -> Bool) -> Rel a b -> (Rel a b,Rel a b)+partitionRng f = Set.partition (f . snd)++intersection :: (Ord a, Ord b) => Rel a b -> Rel a b -> Rel a b+intersection = Set.intersection++difference :: (Ord a, Ord b) => Rel a b -> Rel a b -> Rel a b+difference = Set.difference++union :: (Ord a, Ord b) => Rel a b -> Rel a b -> Rel a b+union = Set.union++unions :: (Ord a, Ord b) => [Rel a b] -> Rel a b+unions = Set.unions++apply :: (Ord a, Ord b) => Rel a b -> a -> [b]+apply r a = Set.toList $ rng $ restrictDom (==a) $ r++toDomMap :: Ord a => Rel a b -> Map.Map a [b]+toDomMap r = Map.unionsWith (++) [ Map.singleton a [b] | (a,b) <- toList r ]++toRngMap :: Ord b => Rel a b -> Map.Map b [a]+toRngMap r = Map.unionsWith (++) [ Map.singleton b [a] | (a,b) <- toList r ]++mapDomRng :: (Ord a, Ord b, Ord a', Ord b') => ((a,b) -> (a',b')) -> Rel a b -> Rel a' b'+mapDomRng = Set.map+
+ src/UHC/Util/ScanUtils.hs view
@@ -0,0 +1,187 @@+module UHC.Util.ScanUtils+ ( ScanOpts(..), defaultScanOpts++ , isNoPos, posIs1stColumn++ , InFilePos(..), infpStart, infpNone+ , infpAdvCol, infpAdvLine, infpAdv1Line, infpAdvStr++ , genTokVal, genTokTp, genTokMap++ , isLF, isStr, isStrQuote+ , isWhite, isBlack+ , isVarStart, isVarRest++ )+ where++import System.IO+import Data.Char+import Data.List+import qualified Data.Set as Set++import UHC.Util.Pretty++import UU.Parsing+import UHC.Util.ParseUtils+import UU.Scanner.Position( noPos, Pos(..), Position(..) )+import UU.Scanner.GenToken++-------------------------------------------------------------------------+-- Utils for GenToken+-------------------------------------------------------------------------++genTokVal :: GenToken v t v -> v+genTokVal (ValToken _ v _) = v+genTokVal (Reserved v _) = v++genTokTp :: GenToken k t v -> Maybe t+genTokTp (ValToken t _ _) = Just t+genTokTp _ = Nothing++genTokMap :: (a->b) -> GenToken a t a -> GenToken b t b+genTokMap f (ValToken t v p) = ValToken t (f v) p+genTokMap f (Reserved k p) = Reserved (f k) p++-------------------------------------------------------------------------+-- Utils for Pos+-------------------------------------------------------------------------++isNoPos :: Pos -> Bool+isNoPos (Pos l c f) = l < 0 || c < 0++posIs1stColumn :: Pos -> Bool+posIs1stColumn p = column p == 1++-------------------------------------------------------------------------+-- InFilePos: Simplified Pos for inside a file only+-------------------------------------------------------------------------++data InFilePos+ = InFilePos { infpLine, infpColumn :: Int }+ deriving (Eq,Ord)++instance Show InFilePos where+ show (InFilePos l c) = if l < 0 || c < 0 then "" else "(" ++ show l ++ ":" ++ show c ++ ")"++infpStart :: InFilePos+infpStart = InFilePos 1 1++infpNone :: InFilePos+infpNone = InFilePos (-1) (-1)++infpAdvCol :: Int -> InFilePos -> InFilePos+infpAdvCol i p = p {infpColumn = i + infpColumn p}++infpAdvStr :: String -> InFilePos -> InFilePos+infpAdvStr s p = infpAdvCol (length s) p++infpAdvLine :: Int -> InFilePos -> InFilePos+infpAdvLine i p = p {infpLine = i + infpLine p, infpColumn = 1}++infpAdv1Line :: InFilePos -> InFilePos+infpAdv1Line = infpAdvLine 1++-------------------------------------------------------------------------+-- PP of parse errors+-------------------------------------------------------------------------++instance Position p => Position (Maybe p) where+ line = maybe (line noPos) line+ column = maybe (column noPos) column+ file = maybe (file noPos) file++instance Position (GenToken k t v) where+ line = line . position+ column = column . position+ file = file . position++instance PP Pos where+ pp (Pos l c f) = ppParens $ (if null f then empty else pp f >|< ":" ) >|< l >|< "," >|< c++-------------------------------------------------------------------------+-- ScanOpts+-------------------------------------------------------------------------++{-+ScanOpts encode all possible options we ever might want to pass to a scanner used inside the EHC project.+Hence not all options are used by all scanners.+-}++data ScanOpts+ = ScanOpts+ { scoKeywordsTxt :: !(Set.Set String) -- identifiers which are keywords+ , scoPragmasTxt :: !(Set.Set String) -- identifiers which are pragmas+ , scoCommandsTxt :: !(Set.Set String) -- identifiers which are commands+ , scoKeywordsOps :: !(Set.Set String) -- operators which are keywords+ , scoKeywExtraChars :: !(Set.Set Char) -- extra chars to be used by identifiers+ , scoSpecChars :: !(Set.Set Char) -- 1 char keywords+ , scoStringDelims :: !String -- allowed delimiter for string+ , scoOpChars :: !(Set.Set Char) -- chars used for operators+ , scoSpecPairs :: !(Set.Set String) -- pairs of chars which form keywords+ , scoDollarIdent :: !Bool -- allow $ encoded identifiers+ , scoOffsideTrigs :: ![String] -- offside triggers+ , scoOffsideTrigsGE :: ![String] -- offside triggers, but allowing equal indentation (for HS 'do' notation, as per Haskell2010)+ , scoOffsideModule :: !String -- offside start of module+ , scoOffsideOpen :: !String -- offside open symbol+ , scoOffsideClose :: !String -- offside close symbol+ , scoLitmode :: !Bool -- do literal scanning+ , scoVerbOpenClose :: ![(String,String)] -- open/close pairs used for verbatim text+ , scoAllowQualified :: !Bool -- allow qualified variations, i.e. prefixing with "XXX."+ , scoAllowFloat :: !Bool -- allow float notation, i.e. numbers with dots inside+ }++defaultScanOpts :: ScanOpts+defaultScanOpts+ = ScanOpts+ { scoKeywordsTxt = Set.empty+ , scoPragmasTxt = Set.empty+ , scoCommandsTxt = Set.empty+ , scoKeywordsOps = Set.empty+ , scoKeywExtraChars = Set.empty+ , scoSpecChars = Set.empty+ , scoStringDelims = "\""+ , scoOpChars = Set.empty+ , scoSpecPairs = Set.empty+ , scoDollarIdent = False+ , scoOffsideTrigs = []+ , scoOffsideTrigsGE = []+ , scoOffsideModule = ""+ , scoOffsideOpen = ""+ , scoOffsideClose = ""+ , scoLitmode = False+ , scoVerbOpenClose = []+ , scoAllowQualified = True+ , scoAllowFloat = True+ }++-------------------------------------------------------------------------+-- Char predicates+-------------------------------------------------------------------------++isLF :: Char -> Bool+isLF = (`elem` "\n\r")++isStrQuote :: Char -> Bool+isStrQuote c = c == '"'++isStr :: Char -> Bool+isStr c = not (isStrQuote c || isLF c)++isVarStart :: Char -> Bool+isVarStart c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'++isVarRest :: Char -> Bool+isVarRest c = isVarStart c || isDigit c || c `elem` "'_"++isWhite :: Char -> Bool+isWhite = (`elem` " \t")++{-+isDig :: Char -> Bool+isDig c = c >= '0' && c <= '9'+-}++isBlack :: Char -> Bool+isBlack c = not (isWhite c || isLF c)+
+ src/UHC/Util/Utils.hs view
@@ -0,0 +1,265 @@+module UHC.Util.Utils where++-- import UHC.Util.Pretty+import Data.Char+import Data.List+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Graph as Graph++-------------------------------------------------------------------------+-- Set+-------------------------------------------------------------------------++unionMapSet :: Ord b => (a -> Set.Set b) -> (Set.Set a -> Set.Set b)+unionMapSet f = Set.unions . map f . Set.toList++-------------------------------------------------------------------------+-- Map+-------------------------------------------------------------------------++inverseMap :: (Ord k, Ord v') => (k -> v -> (v',k')) -> Map.Map k v -> Map.Map v' k'+inverseMap mk = Map.fromList . map (uncurry mk) . Map.toList++showStringMapKeys :: Map.Map String x -> String -> String+showStringMapKeys m sep = concat $ intersperse sep $ Map.keys m++-------------------------------------------------------------------------+-- List+-------------------------------------------------------------------------++hdAndTl' :: a -> [a] -> (a,[a])+hdAndTl' _ (a:as) = (a,as)+hdAndTl' n [] = (n,[])++hdAndTl :: [a] -> (a,[a])+hdAndTl = hdAndTl' (panic "hdAndTl")+{-# INLINE hdAndTl #-}++maybeNull :: r -> ([a] -> r) -> [a] -> r+maybeNull n f l = if null l then n else f l+{-# INLINE maybeNull #-}++maybeHd :: r -> (a -> r) -> [a] -> r+maybeHd n f = maybeNull n (f . head)+{-# INLINE maybeHd #-}++wordsBy :: (a -> Bool) -> [a] -> [[a]]+wordsBy p l+ = w l+ where w [] = []+ w l = let (l',ls') = break p l+ in l' : case ls' of [] -> []+ (_:[]) -> [[]]+ (_:ls'') -> w ls''++initlast :: [a] -> Maybe ([a],a)+initlast as+ = il [] as+ where il acc [a] = Just (reverse acc,a)+ il acc (a:as) = il (a:acc) as+ il _ _ = Nothing++-- | variation on last which returns empty value instead of+last' :: a -> [a] -> a+last' e = maybe e snd . initlast++initlast2 :: [a] -> Maybe ([a],a,a)+initlast2 as+ = il [] as+ where il acc [a,b] = Just (reverse acc,a,b)+ il acc (a:as) = il (a:acc) as+ il _ _ = Nothing++firstNotEmpty :: [[x]] -> [x]+firstNotEmpty = maybeHd [] id . filter (not . null)++-- saturate a list, that is:+-- for all indices i between min and max,+-- if there is no listelement x for which get x returns i,+-- add an element mk i to the list++listSaturate :: (Enum a,Ord a) => a -> a -> (x -> a) -> (a -> x) -> [x] -> [x]+listSaturate min max get mk xs+ = [ Map.findWithDefault (mk i) i mp | i <- [min..max] ]+ where mp = Map.fromList [ (get x,x) | x <- xs ]++-- saturate a list with values from assoc list, that is:+-- for all indices i between min and max,+-- if there is no listelement x for which get x returns i,+-- add a candidate from the associationlist (which must be present) to the list++listSaturateWith :: (Enum a,Ord a) => a -> a -> (x -> a) -> [(a,x)] -> [x] -> [x]+listSaturateWith min max get missing l+ = listSaturate min max get mk l+ where mp = Map.fromList missing+ mk a = panicJust "listSaturateWith" $ Map.lookup a mp++-- variant on span, predicate on full list+spanOnRest :: ([a] -> Bool) -> [a] -> ([a],[a])+spanOnRest p [] = ([],[])+spanOnRest p xs@(x:xs')+ | p xs = (x:ys, zs)+ | otherwise = ([],xs)+ where (ys,zs) = spanOnRest p xs'++-------------------------------------------------------------------------+-- 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)++{-# INLINE tup123to1 #-}+{-# INLINE tup123to2 #-}+{-# INLINE tup123to12 #-}+{-# INLINE tup123to23 #-}+{-# INLINE tup12to123 #-}++-------------------------------------------------------------------------+-- String+-------------------------------------------------------------------------++strWhite :: Int -> String+strWhite sz = replicate sz ' '+{-# INLINE strWhite #-}++strPad :: String -> Int -> String+strPad s sz = s ++ strWhite (sz - length s)++strCapitalize :: String -> String+strCapitalize s+ = case s of+ (c:cs) -> toUpper c : cs+ _ -> s++strToInt :: String -> Int+strToInt = foldl (\i c -> i * 10 + ord c - ord '0') 0++-------------------------------------------------------------------------+-- Split for qualified name+-------------------------------------------------------------------------++splitForQualified :: String -> [String]+splitForQualified s+ = ws''+ where ws = wordsBy (=='.') s+ ws' = case initlast2 ws of+ Just (ns,n,"") -> ns ++ [n ++ "."]+ _ -> ws+ ws''= case break (=="") ws' of+ (nq,(_:ns)) -> nq ++ [concatMap ("."++) ns]+ _ -> ws'++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++panic m = error ("panic: " ++ m)++-------------------------------------------------------------------------+-- group/sort/nub combi's+-------------------------------------------------------------------------++isSortedByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> Bool+isSortedByOn cmp sel l+ = isSrt l+ where isSrt (x1:tl@(x2:_)) = cmp (sel x1) (sel x2) /= GT && isSrt tl+ isSrt _ = True++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn = sortByOn compare+{-# INLINE sortOn #-}++sortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [a]+sortByOn cmp sel = sortBy (\e1 e2 -> sel e1 `cmp` sel e2)++groupOn :: Eq b => (a -> b) -> [a] -> [[a]]+groupOn sel = groupBy (\e1 e2 -> sel e1 == sel e2)++groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]]+groupSortOn sel = groupOn sel . sortOn sel++groupByOn :: (b -> b -> Bool) -> (a -> b) -> [a] -> [[a]]+groupByOn eq sel = groupBy (\e1 e2 -> sel e1 `eq` sel e2)++groupSortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [[a]]+groupSortByOn cmp sel = groupByOn (\e1 e2 -> cmp e1 e2 == EQ) sel . sortByOn cmp sel++nubOn :: Eq b => (a->b) -> [a] -> [a]+nubOn sel = nubBy (\a1 a2 -> sel a1 == sel a2)++-- | The 'consecutiveBy' function groups like groupBy, but based on a function which says whether 2 elements are consecutive+consecutiveBy :: (a -> a -> Bool) -> [a] -> [[a]]+consecutiveBy _ [] = []+consecutiveBy isConsec (x:xs) = ys : consecutiveBy isConsec zs+ where (ys,zs) = consec x xs+ consec x [] = ([x],[])+ consec x yys@(y:ys) | isConsec x y = let (yys',zs) = consec y ys in (x:yys',zs)+ | otherwise = ([x],yys)++-------------------------------------------------------------------------+-- Ordering+-------------------------------------------------------------------------++orderingLexic :: [Ordering] -> Ordering+orderingLexic = foldr1 (\o1 o2 -> if o1 == EQ then o2 else o1)++-------------------------------------------------------------------------+-- Maybe+-------------------------------------------------------------------------++panicJust :: String -> Maybe a -> a+panicJust m = maybe (panic m) id+{-# INLINE panicJust #-}++infixr 0 $?++($?) :: (a -> Maybe b) -> Maybe a -> Maybe b+f $? mx = do x <- mx+ f x++orMb :: Maybe a -> Maybe a -> Maybe a+orMb m1 m2 = maybe m2 (const m1) m1+-- orMb = maybeOr Nothing Just Just++maybeAnd :: x -> (a -> b -> x) -> Maybe a -> Maybe b -> x+maybeAnd n jj ma mb+ = case ma of+ Just a+ -> case mb of {Just b -> jj a b ; _ -> n}+ _ -> n++maybeOr :: x -> (a -> x) -> (b -> x) -> Maybe a -> Maybe b -> x+maybeOr n fa fb ma mb+ = case ma of+ Just a -> fa a+ _ -> case mb of+ Just b -> fb b+ _ -> n++-------------------------------------------------------------------------+-- Strongly Connected Components+-------------------------------------------------------------------------++scc :: Ord n => [(n,[n])] -> [[n]]+scc = map Graph.flattenSCC . Graph.stronglyConnComp . map (\(n,ns) -> (n, n, ns))++-------------------------------------------------------------------------+-- Map+-------------------------------------------------------------------------++-- | double lookup, with transformer for 2nd map+mapLookup2' :: (Ord k1, Ord k2) => (v1 -> Map.Map k2 v2) -> k1 -> k2 -> Map.Map k1 v1 -> Maybe (Map.Map k2 v2, v2)+mapLookup2' f k1 k2 m1+ = do m2 <- Map.lookup k1 m1+ let m2' = f m2+ fmap ((,) m2') $ Map.lookup k2 m2'++-- | double lookup+mapLookup2 :: (Ord k1, Ord k2) => k1 -> k2 -> Map.Map k1 (Map.Map k2 v2) -> Maybe v2+mapLookup2 k1 k2 m1 = fmap snd $ mapLookup2' id k1 k2 m1+{-# INLINE mapLookup2 #-}
+ uhc-util.cabal view
@@ -0,0 +1,50 @@+Name: uhc-util+Version: 0.1.0.0+cabal-version: >= 1.6+License: BSD3+Copyright: Utrecht University, Department of Information and Computing Sciences, Software Technology group+Build-Type: Simple+license-file: LICENSE +Author: Atze Dijkstra+Maintainer: atze@uu.nl+Homepage: https://github.com/UU-ComputerScience/uhc-utils+Bug-Reports: https://github.com/UU-ComputerScience/uhc-utils/issues+Category: Development+Description: General purpose utilities for UHC and related tools+Synopsis: UHC utilities++library+ Build-Depends:+ base >= 4 && < 5,+ mtl >= 2 && < 3,+ fgl >= 5.4 && < 6.0,+ directory >= 1.1 && < 1.2,+ hashable >= 1.1 && < 1.2,+ old-time >= 1.1 && < 1.2,+ containers >= 0.4 && < 0.5,+ array >= 0.4 && < 0.5,+ process >= 1.1 && < 1.2,+ binary >= 0.5 && < 1,+ bytestring >= 0.9 && < 1,+ uulib >= 0.9 && < 1+ Exposed-Modules:+ UHC.Util.AGraph,+ UHC.Util.Binary,+ UHC.Util.CompileRun,+ UHC.Util.Debug,+ UHC.Util.DependencyGraph,+ UHC.Util.FPath,+ UHC.Util.FastSeq,+ UHC.Util.Nm,+ UHC.Util.ParseErrPrettyPrint,+ UHC.Util.ParseUtils,+ UHC.Util.Pretty,+ UHC.Util.PrettySimple,+ UHC.Util.PrettyUtils,+ UHC.Util.Rel,+ UHC.Util.ScanUtils,+ UHC.Util.Utils+ Ghc-Options: + HS-Source-Dirs: src+ Build-Tools: + Extensions: