diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/UHC/Util/AGraph.hs b/src/UHC/Util/AGraph.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/AGraph.hs @@ -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 diff --git a/src/UHC/Util/Binary.hs b/src/UHC/Util/Binary.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Binary.hs @@ -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 + } + diff --git a/src/UHC/Util/CompileRun.hs b/src/UHC/Util/CompileRun.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/CompileRun.hs @@ -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 + diff --git a/src/UHC/Util/Debug.hs b/src/UHC/Util/Debug.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Debug.hs @@ -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 + diff --git a/src/UHC/Util/DependencyGraph.hs b/src/UHC/Util/DependencyGraph.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/DependencyGraph.hs @@ -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 + diff --git a/src/UHC/Util/FPath.hs b/src/UHC/Util/FPath.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/FPath.hs @@ -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) + 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 ) + WriteMode -> return ("",stdout) + AppendMode -> return ("",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) + diff --git a/src/UHC/Util/FastSeq.hs b/src/UHC/Util/FastSeq.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/FastSeq.hs @@ -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) diff --git a/src/UHC/Util/Nm.hs b/src/UHC/Util/Nm.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Nm.hs @@ -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 diff --git a/src/UHC/Util/ParseErrPrettyPrint.hs b/src/UHC/Util/ParseErrPrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/ParseErrPrettyPrint.hs @@ -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 diff --git a/src/UHC/Util/ParseUtils.hs b/src/UHC/Util/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/ParseUtils.hs @@ -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 ] + diff --git a/src/UHC/Util/Pretty.hs b/src/UHC/Util/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Pretty.hs @@ -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 + } diff --git a/src/UHC/Util/PrettySimple.hs b/src/UHC/Util/PrettySimple.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/PrettySimple.hs @@ -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 diff --git a/src/UHC/Util/PrettyUtils.hs b/src/UHC/Util/PrettyUtils.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/PrettyUtils.hs @@ -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 >|< "%" + + diff --git a/src/UHC/Util/Rel.hs b/src/UHC/Util/Rel.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Rel.hs @@ -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 + diff --git a/src/UHC/Util/ScanUtils.hs b/src/UHC/Util/ScanUtils.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/ScanUtils.hs @@ -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) + diff --git a/src/UHC/Util/Utils.hs b/src/UHC/Util/Utils.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Utils.hs @@ -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 #-} diff --git a/uhc-util.cabal b/uhc-util.cabal new file mode 100644 --- /dev/null +++ b/uhc-util.cabal @@ -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: