Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

initial

  • Loading branch information...
commit c9fcc34aa230800319608c453488e44e3e7383c2 1 parent 417ab3e
atzedijkstra atzedijkstra authored
41 LICENSE
... ... @@ -0,0 +1,41 @@
  1 +The Utrecht Haskell Compiler (UHC) License
  2 +==========================================
  3 +
  4 +UHC follows the advertisement free BSD license, of which the basic
  5 +template can be found here:
  6 +
  7 + http://www.opensource.org/licenses/bsd-license.php
  8 +
  9 +UHC uses the following libraries with their own license:
  10 +- Library code from the GHC distribution, see comment in the modules in ehclib
  11 +
  12 +License text
  13 +============
  14 +
  15 +Copyright (c) 2009-2010, Utrecht University, Department of Information
  16 +and Computing Sciences, Software Technology group
  17 +
  18 +All rights reserved.
  19 +
  20 +Redistribution and use in source and binary forms, with or without
  21 +modification, are permitted provided that the following conditions are
  22 +met:
  23 +
  24 + * Redistributions of source code must retain the above copyright
  25 + notice, this list of conditions and the following disclaimer.
  26 +
  27 + * Redistributions in binary form must reproduce the above copyright
  28 + notice, this list of conditions and the following disclaimer in the
  29 + documentation and/or other materials provided with the distribution.
  30 +
  31 +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
  32 +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
  33 +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
  34 +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  35 +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  36 +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  37 +TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  38 +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  39 +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  40 +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  41 +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
12 README.md
Source Rendered
... ... @@ -1,4 +1,14 @@
1 1 uhc-utils
2 2 =========
3 3
4   -Utilities required by UHC (Utrecht Haskell Compiler)
  4 +Utilities required by UHC (Utrecht Haskell Compiler)
  5 +
  6 +
  7 +status/disclamer
  8 +================
  9 +
  10 +Currently the source code is just factored out of UHC, minimally
  11 +commented, all modules in UHC.Util, not yet properly spread using naming
  12 +conventions. Also, some of the modules have become obsolete over time,
  13 +so will someday be removed, to be replaced by other libraries. In other
  14 +words, the library is intended for UHC only.
2  Setup.hs
... ... @@ -0,0 +1,2 @@
  1 +import Distribution.Simple
  2 +main = defaultMain
BIN  src/.DS_Store
Binary file not shown
61 src/UHC/Util/AGraph.hs
... ... @@ -0,0 +1,61 @@
  1 +-------------------------------------------------------------------------
  2 +-- Interface to inductive graph library, by Gerrit vd Geest
  3 +-------------------------------------------------------------------------
  4 +
  5 +module UHC.Util.AGraph
  6 + ( AGraph(agraphGraph)
  7 + , insertEdge
  8 + , insertEdges
  9 + , deleteEdge
  10 + , deleteNode
  11 + , successors
  12 + , predecessors
  13 + , emptyAGraph
  14 + )
  15 + where
  16 +
  17 +import Data.Graph.Inductive.Graph (empty, insNodes, gelem, lab, lpre, lsuc, delEdge, delNode)
  18 +import Data.Graph.Inductive.NodeMap (NodeMap, new, mkNodes, mkNode_, insMapEdge)
  19 +import Data.Graph.Inductive.Tree (Gr)
  20 +import Data.Graph.Inductive.Graphviz (graphviz')
  21 +
  22 +import Data.Maybe (fromJust)
  23 +import Data.List(nub)
  24 +
  25 +data AGraph a b = AGr { agraphNodeMap :: NodeMap a, agraphGraph :: Gr a b}
  26 +
  27 +instance (Show a, Show b) => Show (AGraph a b) where
  28 + show (AGr _ gr) = graphviz' gr
  29 +
  30 +insertEdges :: Ord a => [(a, a, b)] -> AGraph a b -> AGraph a b
  31 +insertEdges = flip (foldr insertEdge)
  32 +
  33 +insertEdge :: Ord a => (a, a, b) -> AGraph a b -> AGraph a b
  34 +insertEdge e@(p, q, _) gr = let (AGr nm' gr') = insMapNodes (p:[q]) gr
  35 + in AGr nm' (insMapEdge nm' e gr')
  36 +
  37 +deleteEdge :: Ord a => (a, a) -> AGraph a b -> AGraph a b
  38 +deleteEdge (p, q) (AGr nm gr) = AGr nm (delEdge (getId p, getId q) gr)
  39 + where getId nd = fst $ mkNode_ nm nd
  40 +
  41 +deleteNode :: Ord a => a -> AGraph a b -> AGraph a b
  42 +deleteNode p (AGr nm gr) = AGr nm (delNode (getId p) gr)
  43 + where getId nd = fst $ mkNode_ nm nd
  44 +
  45 +insMapNodes :: Ord a => [a] -> AGraph a b -> AGraph a b
  46 +insMapNodes as (AGr m g) =
  47 + let (ns, m') = mkNodes m (nub as)
  48 + ns' = filter (\(i, _) -> not $ gelem i g) ns
  49 + in AGr m' (insNodes ns' g)
  50 +
  51 +successors, predecessors :: Ord a => AGraph a b -> a -> [(b, a)]
  52 +successors = neighbours lsuc
  53 +predecessors = neighbours lpre
  54 +
  55 +emptyAGraph :: Ord a => AGraph a b
  56 +emptyAGraph = AGr new empty
  57 +
  58 +neighbours dir (AGr nm gr) node
  59 + | nd `gelem` gr = map (\(n, info) -> (info, fromJust $ lab gr n)) (dir gr nd)
  60 + | otherwise = []
  61 + where nd = fst $ mkNode_ nm node
75 src/UHC/Util/Binary.hs
... ... @@ -0,0 +1,75 @@
  1 +-------------------------------------------------------------------------
  2 +-- Wrapper module around Data.Binary, providing additional functionality
  3 +-------------------------------------------------------------------------
  4 +
  5 +module UHC.Util.Binary
  6 + ( module Data.Binary
  7 + , module Data.Binary.Get
  8 + , module Data.Binary.Put
  9 +
  10 + , hGetBinary
  11 + , getBinaryFile
  12 + , getBinaryFPath
  13 +
  14 + , hPutBinary
  15 + , putBinaryFile
  16 + , putBinaryFPath
  17 + )
  18 + where
  19 +
  20 +import qualified Data.ByteString.Lazy as L
  21 +import Data.Binary
  22 +import Data.Binary.Put(runPut,putWord16be)
  23 +import Data.Binary.Get(runGet,getWord16be)
  24 +import System.IO
  25 +import Control.Monad
  26 +
  27 +import UHC.Util.FPath
  28 +
  29 +-------------------------------------------------------------------------
  30 +-- Decoding from ...
  31 +-------------------------------------------------------------------------
  32 +
  33 +-- | Decode from Handle
  34 +hGetBinary :: Binary a => Handle -> IO a
  35 +hGetBinary h
  36 + = liftM decode (L.hGetContents h)
  37 +
  38 +-- | Decode from FilePath
  39 +getBinaryFile :: Binary a => FilePath -> IO a
  40 +getBinaryFile fn
  41 + = do { h <- openBinaryFile fn ReadMode
  42 + ; b <- hGetBinary h
  43 + -- ; hClose h
  44 + ; return b ;
  45 + }
  46 +
  47 +-- | Decode from FilePath
  48 +getBinaryFPath :: Binary a => FPath -> IO a
  49 +getBinaryFPath fp
  50 + = getBinaryFile (fpathToStr fp)
  51 +
  52 +-------------------------------------------------------------------------
  53 +-- Encoding to ...
  54 +-------------------------------------------------------------------------
  55 +
  56 +-- | Encode to Handle
  57 +hPutBinary :: Binary a => Handle -> a -> IO ()
  58 +hPutBinary h pt
  59 + = L.hPut h (encode pt)
  60 +
  61 +-- | Encode to FilePath
  62 +putBinaryFile :: Binary a => FilePath -> a -> IO ()
  63 +putBinaryFile fn pt
  64 + = do { h <- openBinaryFile fn WriteMode
  65 + ; hPutBinary h pt
  66 + ; hClose h
  67 + }
  68 +
  69 +-- | Encode to FPath, ensuring existence of path
  70 +putBinaryFPath :: Binary a => FPath -> a -> IO ()
  71 +putBinaryFPath fp pt
  72 + = do { fpathEnsureExists fp
  73 + ; putBinaryFile (fpathToStr fp) pt
  74 + }
  75 +
542 src/UHC/Util/CompileRun.hs
... ... @@ -0,0 +1,542 @@
  1 +{-# LANGUAGE UndecidableInstances, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes #-}
  2 +
  3 +-------------------------------------------------------------------------
  4 +-- Combinators for a compile run
  5 +-------------------------------------------------------------------------
  6 +
  7 +module UHC.Util.CompileRun
  8 + ( CompileRunState(..)
  9 + , CompileRun(..)
  10 + , CompilePhase
  11 + , CompileUnit(..)
  12 + , CompileUnitState(..)
  13 + , CompileRunError(..)
  14 + , CompileModName(..)
  15 + , CompileRunStateInfo(..)
  16 +
  17 + , CompileParticipation(..)
  18 +
  19 + , FileLocatable(..)
  20 +
  21 + , mkEmptyCompileRun
  22 +
  23 + , crCU, crMbCU
  24 + , ppCR
  25 +
  26 + , cpUpdStateInfo, cpUpdSI
  27 +
  28 + , cpUpdCU, cpUpdCUWithKey
  29 + , cpSetFail, cpSetStop, cpSetStopSeq, cpSetStopAllSeq
  30 + , cpSetOk, cpSetErrs, cpSetLimitErrs, cpSetLimitErrsWhen, cpSetInfos, cpSetCompileOrder
  31 +
  32 + , cpSeq, cpSeqWhen
  33 + , cpEmpty
  34 +
  35 + , cpFindFileForNameOrFPath
  36 + , cpFindFilesForFPathInLocations, cpFindFilesForFPath, cpFindFileForFPath
  37 + , cpImportGather, cpImportGatherFromMods, cpImportGatherFromModsWithImp
  38 + , cpPP, cpPPMsg
  39 +
  40 + , forgetM
  41 + )
  42 + where
  43 +
  44 +import Data.Maybe
  45 +import System.Exit
  46 +import Control.Monad
  47 +import Control.Monad.State
  48 +import System.IO
  49 +import qualified Data.Map as Map
  50 +import UHC.Util.Pretty
  51 +import UHC.Util.Utils
  52 +import UHC.Util.FPath
  53 +
  54 +
  55 +-------------------------------------------------------------------------
  56 +-- Utility
  57 +-------------------------------------------------------------------------
  58 +
  59 +-- forget result
  60 +forgetM :: Monad m => m a -> m ()
  61 +forgetM m
  62 + = do { _ <- m
  63 + ; return ()
  64 + }
  65 +
  66 +-------------------------------------------------------------------------
  67 +-- The way a CompileUnit can participate
  68 +-------------------------------------------------------------------------
  69 +
  70 +data CompileParticipation
  71 + = CompileParticipation_NoImport
  72 + deriving (Eq, Ord)
  73 +
  74 +-------------------------------------------------------------------------
  75 +-- Interfacing with actual state info
  76 +-------------------------------------------------------------------------
  77 +
  78 +class CompileModName n where
  79 + mkCMNm :: String -> n
  80 +
  81 +class CompileUnitState s where
  82 + cusDefault :: s
  83 + cusUnk :: s
  84 + cusIsUnk :: s -> Bool
  85 + cusIsImpKnown :: s -> Bool
  86 +
  87 +class CompileUnit u n l s | u -> n l s where
  88 + cuDefault :: u
  89 + cuFPath :: u -> FPath
  90 + cuUpdFPath :: FPath -> u -> u
  91 + cuLocation :: u -> l
  92 + cuUpdLocation :: l -> u -> u
  93 + cuKey :: u -> n
  94 + cuUpdKey :: n -> u -> u
  95 + cuState :: u -> s
  96 + cuUpdState :: s -> u -> u
  97 + cuImports :: u -> [n]
  98 + cuParticipation :: u -> [CompileParticipation]
  99 +
  100 + -- defaults
  101 + cuParticipation _ = []
  102 +
  103 +class FPathError e => CompileRunError e p | e -> p where
  104 + crePPErrL :: [e] -> PP_Doc
  105 + creMkNotFoundErrL :: p -> String -> [String] -> [FileSuffix] -> [e]
  106 + creAreFatal :: [e] -> Bool
  107 +
  108 + -- defaults
  109 + crePPErrL _ = empty
  110 + creMkNotFoundErrL _ _ _ _ = []
  111 + creAreFatal _ = True
  112 +
  113 +class CompileRunStateInfo i n p where
  114 + crsiImportPosOfCUKey :: n -> i -> p
  115 +
  116 +-------------------------------------------------------------------------
  117 +-- Instances
  118 +-------------------------------------------------------------------------
  119 +
  120 +instance CompileRunError String p
  121 +
  122 +-------------------------------------------------------------------------
  123 +-- Locatable
  124 +-------------------------------------------------------------------------
  125 +
  126 +class FileLocatable x loc | loc -> x where -- funcdep has unlogical direction, but well...
  127 + fileLocation :: x -> loc
  128 + noFileLocation :: loc
  129 +
  130 +-------------------------------------------------------------------------
  131 +-- State
  132 +-------------------------------------------------------------------------
  133 +
  134 +data CompileRunState err
  135 + = CRSOk -- continue
  136 + | CRSFail -- fail and stop
  137 + | CRSStopSeq -- stop current cpSeq
  138 + | CRSStopAllSeq -- stop current cpSeq, but also the surrounding ones
  139 + | CRSStop -- stop completely
  140 + | CRSFailErrL String [err] (Maybe Int) -- fail with errors and stop
  141 + | CRSErrInfoL String Bool [err] -- just errors, continue
  142 +
  143 +data CompileRun nm unit info err
  144 + = CompileRun
  145 + { crCUCache :: Map.Map nm unit
  146 + , crCompileOrder :: [[nm]]
  147 + , crTopModNm :: nm
  148 + , crState :: CompileRunState err
  149 + , crStateInfo :: info
  150 + }
  151 +
  152 +instance Show (CompileRunState err) where
  153 + show CRSOk = "CRSOk"
  154 + show CRSFail = "CRSFail"
  155 + show CRSStopSeq = "CRSStopSeq"
  156 + show CRSStopAllSeq = "CRSStopAllSeq"
  157 + show CRSStop = "CRSStop"
  158 + show (CRSFailErrL _ _ _) = "CRSFailErrL"
  159 + show (CRSErrInfoL _ _ _) = "CRSErrInfoL"
  160 +
  161 +type CompilePhase n u i e a = StateT (CompileRun n u i e) IO a
  162 +
  163 +
  164 +
  165 +mkEmptyCompileRun :: n -> i -> CompileRun n u i e
  166 +mkEmptyCompileRun nm info
  167 + = CompileRun
  168 + { crCUCache = Map.empty
  169 + , crCompileOrder = []
  170 + , crTopModNm = nm
  171 + , crState = CRSOk
  172 + , crStateInfo = info
  173 + }
  174 +
  175 +-------------------------------------------------------------------------
  176 +-- Pretty printing
  177 +-------------------------------------------------------------------------
  178 +
  179 +ppCR :: (PP n,PP u) => CompileRun n u i e -> PP_Doc
  180 +ppCR cr
  181 + = "CR" >#< show (crState cr) >|< ":" >#<
  182 + ( (ppListSepVV "[" "]" "," $ map (\(n,u) -> pp n >#< "->" >#< pp u) $ Map.toList $ crCUCache $ cr)
  183 + >-< ppBracketsCommas (map ppBracketsCommas $ crCompileOrder $ cr)
  184 + )
  185 +
  186 +crPP :: (PP n,PP u) => String -> CompileRun n u i e -> IO (CompileRun n u i e)
  187 +crPP m cr = do { hPutStrLn stderr (m ++ ":") ; hPutPPLn stderr (ppCR cr) ; hFlush stderr ; return cr }
  188 +
  189 +crPPMsg :: (PP m) => m -> CompileRun n u i e -> IO (CompileRun n u i e)
  190 +crPPMsg m cr = do { hPutPPLn stdout (pp m) ; return cr }
  191 +
  192 +cpPP :: (PP n,PP u) => String -> CompilePhase n u i e ()
  193 +cpPP m
  194 + = do { lift (hPutStrLn stderr (m ++ ":"))
  195 + ; cr <- get
  196 + ; lift (hPutPPLn stderr (ppCR cr))
  197 + ; lift (hFlush stderr)
  198 + ; return ()
  199 + }
  200 +
  201 +cpPPMsg :: (PP m) => m -> CompilePhase n u i e ()
  202 +cpPPMsg m
  203 + = do { lift (hPutPPLn stdout (pp m))
  204 + ; return ()
  205 + }
  206 +
  207 +
  208 +
  209 +-------------------------------------------------------------------------
  210 +-- State manipulation, sequencing: compile unit
  211 +-------------------------------------------------------------------------
  212 +
  213 +crMbCU :: Ord n => n -> CompileRun n u i e -> Maybe u
  214 +crMbCU modNm cr = Map.lookup modNm (crCUCache cr)
  215 +
  216 +crCU :: (Show n,Ord n) => n -> CompileRun n u i e -> u
  217 +crCU modNm = panicJust ("crCU: " ++ show modNm) . crMbCU modNm
  218 +
  219 +-------------------------------------------------------------------------
  220 +-- State manipulation, sequencing: non monadic
  221 +-------------------------------------------------------------------------
  222 +
  223 +crSetFail :: CompileRun n u i e -> CompileRun n u i e
  224 +crSetFail cr = cr {crState = CRSFail}
  225 +
  226 +crSetStop :: CompileRun n u i e -> CompileRun n u i e
  227 +crSetStop cr = cr {crState = CRSStop}
  228 +
  229 +crSetStopSeq :: CompileRun n u i e -> CompileRun n u i e
  230 +crSetStopSeq cr = cr {crState = CRSStopSeq}
  231 +
  232 +crSetStopAllSeq :: CompileRun n u i e -> CompileRun n u i e
  233 +crSetStopAllSeq cr = cr {crState = CRSStopAllSeq}
  234 +
  235 +crSetErrs' :: Maybe Int -> String -> [e] -> CompileRun n u i e -> CompileRun n u i e
  236 +crSetErrs' limit about es cr
  237 + = case es of
  238 + [] -> cr
  239 + _ -> cr {crState = CRSFailErrL about es limit}
  240 +
  241 +crSetInfos' :: String -> Bool -> [e] -> CompileRun n u i e -> CompileRun n u i e
  242 +crSetInfos' msg dp is cr
  243 + = case is of
  244 + [] -> cr
  245 + _ -> cr {crState = CRSErrInfoL msg dp is}
  246 +
  247 +-------------------------------------------------------------------------
  248 +-- Compile unit observations
  249 +-------------------------------------------------------------------------
  250 +
  251 +crCUState :: (Ord n,CompileUnit u n l s,CompileUnitState s) => n -> CompileRun n u i e -> s
  252 +crCUState modNm cr = maybe cusUnk cuState (crMbCU modNm cr)
  253 +
  254 +crCUFPath :: (Ord n,CompileUnit u n l s) => n -> CompileRun n u i e -> FPath
  255 +crCUFPath modNm cr = maybe emptyFPath cuFPath (crMbCU modNm cr)
  256 +
  257 +crCULocation :: (Ord n,FileLocatable u loc) => n -> CompileRun n u i e -> loc
  258 +crCULocation modNm cr = maybe noFileLocation fileLocation (crMbCU modNm cr)
  259 +
  260 +-------------------------------------------------------------------------
  261 +-- Find file for FPath
  262 +-------------------------------------------------------------------------
  263 +
  264 +cpFindFileForNameOrFPath :: (FPATH n) => String -> n -> FPath -> [(String,FPath)]
  265 +cpFindFileForNameOrFPath loc _ fp = searchFPathFromLoc loc fp
  266 +
  267 +cpFindFilesForFPathInLocations
  268 + :: ( Ord n
  269 + , FPATH n, FileLocatable u loc, Show loc
  270 + , CompileUnitState s,CompileRunError e p,CompileUnit u n loc s,CompileModName n,CompileRunStateInfo i n p
  271 + ) => (loc -> n -> FPath -> [(loc,FPath,[e])]) -> ((FPath,loc,[e]) -> res)
  272 + -> Bool -> [(FileSuffix,s)] -> [loc] -> Maybe n -> Maybe FPath -> CompilePhase n u i e [res]
  273 +cpFindFilesForFPathInLocations getfp putres stopAtFirst suffs locs mbModNm mbFp
  274 + = do { cr <- get
  275 + ; let cus = maybe cusUnk (flip crCUState cr) mbModNm
  276 + ; if cusIsUnk cus
  277 + then do { let fp = maybe (mkFPath $ panicJust ("cpFindFileForFPath") $ mbModNm) id mbFp
  278 + modNm = maybe (mkCMNm $ fpathBase $ fp) id mbModNm
  279 + suffs' = map fst suffs
  280 + ; fpsFound <- lift (searchLocationsForReadableFiles (\l f -> getfp l modNm f)
  281 + stopAtFirst locs suffs' fp
  282 + )
  283 + ; case fpsFound of
  284 + []
  285 + -> do { cpSetErrs (creMkNotFoundErrL (crsiImportPosOfCUKey modNm (crStateInfo cr)) (fpathToStr fp) (map show locs) suffs')
  286 + ; return []
  287 + }
  288 + ((_,_,e@(_:_)):_)
  289 + -> do { cpSetErrs e
  290 + ; return []
  291 + }
  292 + ffs@((ff,loc,_):_)
  293 + -> do { cpUpdCU modNm (cuUpdLocation loc . cuUpdFPath ff . cuUpdState cus . cuUpdKey modNm)
  294 + ; return (map putres ffs)
  295 + }
  296 + where cus = case lookup (Just $ fpathSuff ff) suffs of
  297 + Just c -> c
  298 + Nothing -> case lookup (Just "*") suffs of
  299 + Just c -> c
  300 + Nothing -> cusUnk
  301 + }
  302 + else return (maybe [] (\nm -> [putres (crCUFPath nm cr,crCULocation nm cr,[])]) mbModNm)
  303 + }
  304 +
  305 +cpFindFilesForFPath
  306 + :: forall e n u p i s .
  307 + ( Ord n
  308 + , FPATH n, FileLocatable u String
  309 + , CompileUnitState s,CompileRunError e p,CompileUnit u n String s,CompileModName n,CompileRunStateInfo i n p
  310 + ) => Bool -> [(FileSuffix,s)] -> [String] -> Maybe n -> Maybe FPath -> CompilePhase n u i e [FPath]
  311 +cpFindFilesForFPath
  312 + = cpFindFilesForFPathInLocations (\l n f -> map (tup12to123 ([]::[e])) $ cpFindFileForNameOrFPath l n f) tup123to1
  313 +
  314 +cpFindFileForFPath
  315 + :: ( Ord n
  316 + , FPATH n, FileLocatable u String
  317 + , CompileUnitState s,CompileRunError e p,CompileUnit u n String s,CompileModName n,CompileRunStateInfo i n p
  318 + ) => [(FileSuffix,s)] -> [String] -> Maybe n -> Maybe FPath -> CompilePhase n u i e (Maybe FPath)
  319 +cpFindFileForFPath suffs sp mbModNm mbFp
  320 + = do { fps <- cpFindFilesForFPath True suffs sp mbModNm mbFp
  321 + ; return (listToMaybe fps)
  322 + }
  323 +
  324 +-------------------------------------------------------------------------
  325 +-- Gather all imports
  326 +-------------------------------------------------------------------------
  327 +
  328 +-- | recursively extract imported modules, providing a way to import + do the import
  329 +cpImportGatherFromModsWithImp
  330 + :: (Show n, Ord n, CompileUnit u n l s, CompileRunError e p, CompileUnitState s)
  331 + => (u -> [n]) -- get imports
  332 + -> (Maybe prev -> n -> CompilePhase n u i e (x,Maybe prev)) -- extract imports from 1 module
  333 + -> [n] -- to be imported modules
  334 + -> CompilePhase n u i e ()
  335 +cpImportGatherFromModsWithImp getImports imp1Mod modNmL
  336 + = do { cr <- get
  337 + ; cpSeq ( [ one Nothing modNm | modNm <- modNmL ]
  338 + ++ [ cpImportScc ]
  339 + )
  340 + }
  341 + where one prev modNm
  342 + = do { (_,new) <- imp1Mod prev modNm
  343 + ; cpHandleErr
  344 + ; cr <- get
  345 + ; if CompileParticipation_NoImport `elem` cuParticipation (crCU modNm cr)
  346 + then cpDelCU modNm
  347 + else imps new modNm
  348 + }
  349 + imps prev m
  350 + = do { cr <- get
  351 + ; let impL m = [ i | i <- getImports (crCU m cr), not (cusIsImpKnown (crCUState i cr)) ]
  352 + ; cpSeq (map (\n -> one prev n) (impL m))
  353 + }
  354 +
  355 +-- | recursively extract imported modules
  356 +cpImportGatherFromMods
  357 + :: (Show n, Ord n, CompileUnit u n l s, CompileRunError e p, CompileUnitState s)
  358 + => (Maybe prev -> n -> CompilePhase n u i e (x,Maybe prev)) -- extract imports from 1 module
  359 + -> [n] -- to be imported modules
  360 + -> CompilePhase n u i e ()
  361 +cpImportGatherFromMods = cpImportGatherFromModsWithImp cuImports
  362 +
  363 +-- | Abbreviation for cpImportGatherFromMods for 1 module
  364 +cpImportGather
  365 + :: (Show n,Ord n,CompileUnit u n l s,CompileRunError e p,CompileUnitState s)
  366 + => (n -> CompilePhase n u i e ()) -> n -> CompilePhase n u i e ()
  367 +cpImportGather imp1Mod modNm
  368 + = cpImportGatherFromMods
  369 + (\_ n -> do { r <- imp1Mod n
  370 + ; return (r,Nothing)
  371 + }
  372 + )
  373 + [modNm]
  374 +
  375 +crImportDepL :: (CompileUnit u n l s) => CompileRun n u i e -> [(n,[n])]
  376 +crImportDepL = map (\cu -> (cuKey cu,cuImports cu)) . Map.elems . crCUCache
  377 +
  378 +cpImportScc :: (Ord n,CompileUnit u n l s) => CompilePhase n u i e ()
  379 +cpImportScc = modify (\cr -> (cr {crCompileOrder = scc (crImportDepL cr)}))
  380 +
  381 +
  382 +-------------------------------------------------------------------------
  383 +-- State manipulation, state update (Monadic)
  384 +-------------------------------------------------------------------------
  385 +
  386 +cpUpdStateInfo, cpUpdSI :: (i -> i) -> CompilePhase n u i e ()
  387 +cpUpdStateInfo upd
  388 + = do { cr <- get
  389 + ; put (cr {crStateInfo = upd (crStateInfo cr)})
  390 + }
  391 +
  392 +cpUpdSI = cpUpdStateInfo
  393 +
  394 +-------------------------------------------------------------------------
  395 +-- State manipulation, compile unit update (Monadic)
  396 +-------------------------------------------------------------------------
  397 +
  398 +cpUpdCUM :: (Ord n,CompileUnit u n l s) => n -> (u -> IO u) -> CompilePhase n u i e ()
  399 +cpUpdCUM modNm upd
  400 + = do { cr <- get
  401 + ; cu <- lift (maybe (upd cuDefault) upd (crMbCU modNm cr))
  402 + ; put (cr {crCUCache = Map.insert modNm cu (crCUCache cr)})
  403 + }
  404 +
  405 +
  406 +cpUpdCUWithKey :: (Ord n,CompileUnit u n l s) => n -> (n -> u -> (n,u)) -> CompilePhase n u i e n
  407 +cpUpdCUWithKey modNm upd
  408 + = do { cr <- get
  409 + ; let (modNm',cu) = (maybe (upd modNm cuDefault) (upd modNm) (crMbCU modNm cr))
  410 + ; put (cr {crCUCache = Map.insert modNm' cu $ Map.delete modNm $ crCUCache cr})
  411 + ; return modNm'
  412 + }
  413 +
  414 +cpUpdCU :: (Ord n,CompileUnit u n l s) => n -> (u -> u) -> CompilePhase n u i e ()
  415 +cpUpdCU modNm upd
  416 + = do { cpUpdCUWithKey modNm (\k u -> (k, upd u))
  417 + ; return ()
  418 + }
  419 +
  420 +-- | delete unit
  421 +cpDelCU :: (Ord n,CompileUnit u n l s) => n -> CompilePhase n u i e ()
  422 +cpDelCU modNm
  423 + = do { modify (\cr -> cr {crCUCache = Map.delete modNm $ crCUCache cr})
  424 + }
  425 +{-
  426 + = do { cr <- get
  427 + ; let cu = (maybe (upd cuDefault) upd (crMbCU modNm cr))
  428 + ; put (cr {crCUCache = Map.insert modNm cu (crCUCache cr)})
  429 + }
  430 +-}
  431 +{-
  432 +cpUpdCU modNm upd
  433 + = cpUpdCUM modNm (return . upd)
  434 +-}
  435 +
  436 +-------------------------------------------------------------------------
  437 +-- State manipulation, sequencing (Monadic)
  438 +-------------------------------------------------------------------------
  439 +
  440 +cpSetErrs :: [e] -> CompilePhase n u i e ()
  441 +cpSetErrs es
  442 + = modify (crSetErrs' Nothing "" es)
  443 +
  444 +cpSetInfos :: String -> Bool -> [e] -> CompilePhase n u i e ()
  445 +cpSetInfos msg dp is
  446 + = modify (crSetInfos' msg dp is)
  447 +
  448 +cpSetFail :: CompilePhase n u i e ()
  449 +cpSetFail
  450 + = modify crSetFail
  451 +
  452 +cpSetStop :: CompilePhase n u i e ()
  453 +cpSetStop
  454 + = modify crSetStop
  455 +
  456 +cpSetStopSeq :: CompilePhase n u i e ()
  457 +cpSetStopSeq
  458 + = modify crSetStopSeq
  459 +
  460 +cpSetStopAllSeq :: CompilePhase n u i e ()
  461 +cpSetStopAllSeq
  462 + = modify crSetStopAllSeq
  463 +
  464 +cpSetOk :: CompilePhase n u i e ()
  465 +cpSetOk
  466 + = modify (\cr -> (cr {crState = CRSOk}))
  467 +
  468 +cpSetCompileOrder :: [[n]] -> CompilePhase n u i e ()
  469 +cpSetCompileOrder nameLL
  470 + = modify (\cr -> (cr {crCompileOrder = nameLL}))
  471 +
  472 +cpSetLimitErrs, cpSetLimitErrsWhen :: Int -> String -> [e] -> CompilePhase n u i e ()
  473 +cpSetLimitErrs l a e
  474 + = modify (crSetErrs' (Just l) a e)
  475 +
  476 +cpSetLimitErrsWhen l a e
  477 + = do { when (not (null e))
  478 + (cpSetLimitErrs l a e)
  479 + }
  480 +
  481 +cpEmpty :: CompilePhase n u i e ()
  482 +cpEmpty = return ()
  483 +
  484 +-- sequence of phases, each may stop the whole sequencing
  485 +cpSeq :: CompileRunError e p => [CompilePhase n u i e ()] -> CompilePhase n u i e ()
  486 +cpSeq [] = return ()
  487 +cpSeq (a:as) = do { a
  488 + ; cpHandleErr
  489 + ; cr <- get
  490 + ; case crState cr of
  491 + CRSOk -> cpSeq as
  492 + CRSStopSeq -> cpSetOk
  493 + CRSStopAllSeq -> cpSetStopAllSeq
  494 + _ -> return ()
  495 + }
  496 +
  497 +-- conditional sequence
  498 +cpSeqWhen :: CompileRunError e p => Bool -> [CompilePhase n u i e ()] -> CompilePhase n u i e ()
  499 +cpSeqWhen True as = cpSeq as
  500 +cpSeqWhen _ _ = return ()
  501 +
  502 +-- handle possible error in sequence
  503 +cpHandleErr :: CompileRunError e p => CompilePhase n u i e ()
  504 +cpHandleErr
  505 + = do { cr <- get
  506 + ; case crState cr of
  507 + CRSFailErrL about es (Just lim)
  508 + -> do { let (showErrs,omitErrs) = splitAt lim es
  509 + ; lift (unless (null about) (hPutPPLn stderr (pp about)))
  510 + ; lift (putErr' (if null omitErrs then return () else hPutStrLn stderr "... and more errors") showErrs)
  511 + ; failOrNot es
  512 + }
  513 + CRSFailErrL about es Nothing
  514 + -> do { lift (unless (null about) (hPutPPLn stderr (pp about)))
  515 + ; lift (putErr' (return ()) es)
  516 + ; failOrNot es
  517 + }
  518 + CRSErrInfoL about doPrint is
  519 + -> do { if null is
  520 + then return ()
  521 + else lift (do { hFlush stdout
  522 + ; hPutPPLn stderr (about >#< "found errors" >-< e)
  523 + })
  524 + ; if not (null is) then lift exitFailure else return ()
  525 + }
  526 + where e = empty -- if doPrint then crePPErrL is else empty
  527 + CRSFail
  528 + -> do { lift exitFailure
  529 + }
  530 + CRSStop
  531 + -> do { lift $ exitWith ExitSuccess
  532 + }
  533 + _ -> return ()
  534 + }
  535 + where putErr' m e = if null e
  536 + then return ()
  537 + else do { hPutPPLn stderr (crePPErrL e)
  538 + ; m
  539 + ; hFlush stderr
  540 + }
  541 + failOrNot es = if creAreFatal es then lift exitFailure else cpSetOk
  542 +
16 src/UHC/Util/Debug.hs
... ... @@ -0,0 +1,16 @@
  1 +module UHC.Util.Debug
  2 + ( tr, trp
  3 + )
  4 + where
  5 +
  6 +import UHC.Util.Pretty
  7 +import UHC.Util.PrettyUtils
  8 +import Debug.Trace
  9 +
  10 +-------------------------------------------------------------------------
  11 +-- Tracing
  12 +-------------------------------------------------------------------------
  13 +
  14 +tr m s v = trace (m ++ show s) v
  15 +trp m s v = trace (m ++ "\n" ++ disp (m >|< ":" >#< s) 1000 "") v
  16 +
167 src/UHC/Util/DependencyGraph.hs
... ... @@ -0,0 +1,167 @@
  1 +-------------------------------------------------------------------------
  2 +-- Graph for version/view dpd
  3 +-------------------------------------------------------------------------
  4 +
  5 +module UHC.Util.DependencyGraph
  6 + ( DpdGr
  7 + , dgTopSort
  8 + , dgVertices
  9 + , dgReachableFrom, dgReachableTo
  10 + , dgDpdsOn
  11 + , dgIsFirst
  12 + , dgCheckSCCMutuals
  13 + , dgSCCToList
  14 + , mkDpdGrFromEdges
  15 + , mkDpdGrFromEdgesMp, mkDpdGrFromEdgesMpPadMissing
  16 + , mkDpdGrFromAssocWithMissing
  17 + , mkDpdGrFromOrderWithMissing
  18 + )
  19 + where
  20 +
  21 +import qualified Data.Set as Set
  22 +import qualified Data.Map as Map
  23 +import Data.Graph
  24 +import UHC.Util.Pretty
  25 +-- import UHC.Util.Nm
  26 +-- import Err
  27 +
  28 +-------------------------------------------------------------------------
  29 +-- DpdGr
  30 +-------------------------------------------------------------------------
  31 +
  32 +data DpdGr n
  33 + = DpdGr
  34 + { dgGr :: Graph
  35 + , dgGrT :: Graph
  36 + , dgEdges :: [(n, n, [n])]
  37 + , dgV2N :: Vertex -> (n, [n])
  38 + , dgK2V :: n -> Maybe Vertex
  39 + }
  40 +
  41 +emptyDpdGr :: Ord n => DpdGr n
  42 +emptyDpdGr = mkDpdGrFromOrderWithMissing [] []
  43 +
  44 +-------------------------------------------------------------------------
  45 +-- Pretty printing
  46 +-------------------------------------------------------------------------
  47 +
  48 +instance Show (DpdGr n) where
  49 + show _ = "DpdGr"
  50 +
  51 +instance (Ord n,PP n) => PP (DpdGr n) where
  52 + pp g = "DpdGr" >#< ("topsort:" >#< ppCommas (dgTopSort g) >-< "scc :" >#< ppBracketsCommas (dgSCC g) >-< "edges :" >#< (ppBracketsCommas $ map (\(n,_,ns) -> n >|< ":" >|< ppBracketsCommas ns) $ dgEdges $ g))
  53 +
  54 +instance Show (SCC n) where
  55 + show _ = "SCC"
  56 +
  57 +instance PP n => PP (SCC n) where
  58 + pp (AcyclicSCC n ) = "ASCC" >#< n
  59 + pp (CyclicSCC ns) = "CSCC" >#< ppBracketsCommas ns
  60 +
  61 +-------------------------------------------------------------------------
  62 +-- Building from dpds
  63 +-------------------------------------------------------------------------
  64 +
  65 +dpdGrFromEdgesMp :: Ord n => [Map.Map n [n]] -> ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])])
  66 +dpdGrFromEdgesMp ns
  67 + = (graphFromEdges es,es)
  68 + where cmbChain = Map.unionWith (++)
  69 + mkEdges = map (\(n,ns) -> (n,n,ns)) . Map.toList
  70 + es = mkEdges . foldr cmbChain Map.empty $ ns
  71 +
  72 +dpdGrFromEdges :: Ord n => [[(n,[n])]] -> ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])])
  73 +dpdGrFromEdges
  74 + = dpdGrFromEdgesMp . map Map.fromList
  75 +
  76 +dpdGrFromOrder :: Ord n => [[n]] -> ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])])
  77 +dpdGrFromOrder
  78 + = dpdGrFromEdgesMp . map mkChain
  79 + where mkChain = Map.fromList . fst . foldl (\(c,prev) n -> ((n,prev) : c,[n])) ([],[])
  80 +
  81 +mkDpdGr :: Ord n => ((Graph, Vertex -> (n, n, [n]), n -> Maybe Vertex),[(n, n, [n])]) -> DpdGr n
  82 +mkDpdGr ((g,n2,v2),es)
  83 + = DpdGr g (transposeG g) es (\v -> let (n,_,ns) = n2 v in (n,ns)) v2
  84 +
  85 +mkDpdGrFromEdgesMp :: Ord n => Map.Map n [n] -> DpdGr n
  86 +mkDpdGrFromEdgesMp
  87 + = mkDpdGr . dpdGrFromEdgesMp . (:[])
  88 +
  89 +mkDpdGrFromEdges :: Ord n => [(n,[n])] -> DpdGr n
  90 +mkDpdGrFromEdges
  91 + = mkDpdGr . dpdGrFromEdges . (:[])
  92 +
  93 +mkDpdGrFromEdgesMpWithMissing :: Ord n => [n] -> Map.Map n [n] -> DpdGr n
  94 +mkDpdGrFromEdgesMpWithMissing missing
  95 + = mkDpdGrFromEdgesMp
  96 + . (Map.fromList [(n,[n]) | n <- missing] `Map.union`)
  97 +
  98 +mkDpdGrFromEdgesMpPadMissing :: Ord n => Map.Map n [n] -> DpdGr n
  99 +mkDpdGrFromEdgesMpPadMissing m
  100 + = mkDpdGrFromEdgesMpWithMissing [ n | ns <- Map.elems m, n <- ns, not (Map.member n m) ] m
  101 +
  102 +mkDpdGrFromOrderWithMissing :: Ord n => [n] -> [[n]] -> DpdGr n
  103 +mkDpdGrFromOrderWithMissing missing
  104 + = mkDpdGr . dpdGrFromOrder
  105 + . ([[n] | n <- missing] ++)
  106 +
  107 +mkDpdGrFromAssocWithMissing :: Ord n => [n] -> [(n,n)] -> DpdGr n
  108 +mkDpdGrFromAssocWithMissing missing
  109 + = mkDpdGr . dpdGrFromEdges
  110 + . map (\(n1,n2) -> [(n1,[n2])])
  111 + . ([(n,n) | n <- missing] ++)
  112 +
  113 +-------------------------------------------------------------------------
  114 +-- Misc
  115 +-------------------------------------------------------------------------
  116 +
  117 +dgVsToNs :: DpdGr n -> [Vertex] -> [n]
  118 +dgVsToNs g = map (\v -> fst (dgV2N g v))
  119 +
  120 +-------------------------------------------------------------------------
  121 +-- Derived info
  122 +-------------------------------------------------------------------------
  123 +
  124 +dgTopSort :: DpdGr n -> [n]
  125 +dgTopSort g = dgVsToNs g . topSort . dgGr $ g
  126 +
  127 +dgVertices :: Ord n => DpdGr n -> Set.Set n
  128 +dgVertices g = Set.fromList . dgVsToNs g . vertices . dgGr $ g
  129 +
  130 +dgReachable :: Ord n => (DpdGr n -> Graph) -> DpdGr n -> n -> Set.Set n
  131 +dgReachable gOf g n
  132 + = case dgK2V g n of
  133 + Just n' -> Set.fromList . dgVsToNs g $ reachable (gOf g) n'
  134 + Nothing -> Set.empty
  135 +
  136 +dgReachableFrom :: Ord n => DpdGr n -> n -> Set.Set n
  137 +dgReachableFrom = dgReachable dgGr
  138 +
  139 +dgReachableTo :: Ord n => DpdGr n -> n -> Set.Set n
  140 +dgReachableTo = dgReachable dgGrT
  141 +
  142 +dgDpdsOn :: DpdGr n -> n -> [n]
  143 +dgDpdsOn g n = maybe [] (snd . dgV2N g) (dgK2V g n)
  144 +
  145 +dgIsFirst :: Ord n => DpdGr n -> n -> Set.Set n -> Bool
  146 +dgIsFirst g n ns
  147 + = Set.null s
  148 + where s = Set.delete n ns `Set.difference` dgReachableTo g n
  149 +
  150 +-------------------------------------------------------------------------
  151 +-- SCC
  152 +-------------------------------------------------------------------------
  153 +
  154 +dgSCC :: Ord n => DpdGr n -> [SCC n]
  155 +dgSCC g = stronglyConnComp . dgEdges $ g
  156 +
  157 +dgSCCToList :: Ord n => DpdGr n -> [[n]]
  158 +dgSCCToList = map (flattenSCC) . dgSCC
  159 +
  160 +dgSCCMutuals :: Ord n => DpdGr n -> [[n]]
  161 +dgSCCMutuals g = [ ns | (CyclicSCC ns@(_:_:_)) <- dgSCC g ]
  162 +
  163 +dgCheckSCCMutuals :: (Ord n,PP n) => ([PP_Doc] -> err) -> DpdGr n -> [err]
  164 +dgCheckSCCMutuals mk g
  165 + = if null ns then [] else [mk $ map pp $ concat $ ns]
  166 + where ns = dgSCCMutuals g
  167 +
353 src/UHC/Util/FPath.hs
... ... @@ -0,0 +1,353 @@
  1 +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  2 +
  3 +module UHC.Util.FPath
  4 + ( FPath(..), fpathSuff
  5 + , FPATH(..)
  6 + , FPathError -- (..)
  7 + , emptyFPath
  8 + -- , mkFPath
  9 + , fpathFromStr
  10 + , mkFPathFromDirsFile
  11 + , fpathToStr, fpathIsEmpty
  12 + , fpathSetBase, fpathSetSuff, fpathSetDir
  13 + , fpathUpdBase
  14 + , fpathRemoveSuff, fpathRemoveDir
  15 +
  16 + , fpathIsAbsolute
  17 +
  18 + , fpathAppendDir, fpathUnAppendDir
  19 + , fpathPrependDir, fpathUnPrependDir
  20 + , fpathSplitDirBy
  21 + , mkTopLevelFPath
  22 +
  23 + , fpathDirSep, fpathDirSepChar
  24 +
  25 + , fpathOpenOrStdin, openFPath
  26 +
  27 + , SearchPath
  28 + , FileSuffixes, FileSuffix
  29 + , mkInitSearchPath, searchPathFromFPath, searchPathFromFPaths
  30 + , searchPathFromString
  31 + , searchFPathFromLoc
  32 + , searchLocationsForReadableFiles, searchPathForReadableFiles, searchPathForReadableFile
  33 +
  34 + , fpathEnsureExists
  35 +
  36 + , filePathMkPrefix, filePathUnPrefix
  37 + , filePathCoalesceSeparator
  38 + , filePathMkAbsolute, filePathUnAbsolute
  39 + )
  40 +where
  41 +
  42 +import Data.Maybe
  43 +import Data.List
  44 +import Control.Monad
  45 +import System.IO
  46 +import System.Directory
  47 +
  48 +import UHC.Util.Utils
  49 +
  50 +-------------------------------------------------------------------------------------------
  51 +-- Making prefix and inverse, where a prefix has a tailing '/'
  52 +-------------------------------------------------------------------------------------------
  53 +
  54 +filePathMkPrefix :: String -> String
  55 +filePathMkPrefix d@(_:_) | last d /= '/' = d ++ "/"
  56 +filePathMkPrefix d = d
  57 +
  58 +filePathUnPrefix :: String -> String
  59 +filePathUnPrefix d | isJust il && l == '/' = filePathUnPrefix i
  60 + where il = initlast d
  61 + (i,l) = fromJust il
  62 +filePathUnPrefix d = d
  63 +
  64 +filePathCoalesceSeparator :: String -> String
  65 +filePathCoalesceSeparator ('/':d@('/':_)) = filePathCoalesceSeparator d
  66 +filePathCoalesceSeparator (c:d) = c : filePathCoalesceSeparator d
  67 +filePathCoalesceSeparator d = d
  68 +
  69 +-------------------------------------------------------------------------------------------
  70 +-- Making into absolute path and inverse, where absolute means a heading '/'
  71 +-------------------------------------------------------------------------------------------
  72 +
  73 +filePathMkAbsolute :: String -> String
  74 +filePathMkAbsolute d@('/':_ ) = d
  75 +filePathMkAbsolute d = "/" ++ d
  76 +
  77 +filePathUnAbsolute :: String -> String
  78 +filePathUnAbsolute d@('/':d') = filePathUnAbsolute d'
  79 +filePathUnAbsolute d = d
  80 +
  81 +-------------------------------------------------------------------------------------------
  82 +-- File path
  83 +-------------------------------------------------------------------------------------------
  84 +
  85 +data FPath
  86 + = FPath
  87 + { fpathMbDir :: !(Maybe String)
  88 + , fpathBase :: !String
  89 + , fpathMbSuff :: !(Maybe String)
  90 + }
  91 + deriving (Show,Eq,Ord)
  92 +
  93 +emptyFPath :: FPath
  94 +emptyFPath
  95 + = mkFPath ""
  96 +
  97 +fpathIsEmpty :: FPath -> Bool
  98 +fpathIsEmpty fp = null (fpathBase fp)
  99 +
  100 +fpathToStr :: FPath -> String
  101 +fpathToStr fpath
  102 + = let adds f = maybe f (\s -> f ++ "." ++ s) (fpathMbSuff fpath)
  103 + addd f = maybe f (\d -> d ++ fpathDirSep ++ f) (fpathMbDir fpath)
  104 + in addd . adds . fpathBase $ fpath
  105 +
  106 +-------------------------------------------------------------------------------------------
  107 +-- Observations
  108 +-------------------------------------------------------------------------------------------
  109 +
  110 +-- TBD. does not work under WinXX, use FilePath library
  111 +fpathIsAbsolute :: FPath -> Bool
  112 +fpathIsAbsolute fp
  113 + = case fpathMbDir fp of
  114 + Just ('/':_) -> True
  115 + _ -> False
  116 +
  117 +-------------------------------------------------------------------------------------------
  118 +-- Utilities, (de)construction
  119 +-------------------------------------------------------------------------------------------
  120 +
  121 +fpathFromStr :: String -> FPath
  122 +fpathFromStr fn
  123 + = FPath d b' s
  124 + where (d ,b) = maybe (Nothing,fn) (\(d,b) -> (Just d,b)) (splitOnLast fpathDirSepChar fn)
  125 + (b',s) = maybe (b,Nothing) (\(b,s) -> (b,Just s)) (splitOnLast '.' b )
  126 +
  127 +fpathDirFromStr :: String -> FPath
  128 +fpathDirFromStr d = emptyFPath {fpathMbDir = Just d}
  129 +
  130 +fpathSuff :: FPath -> String
  131 +fpathSuff = maybe "" id . fpathMbSuff
  132 +
  133 +fpathSetBase :: String -> FPath -> FPath
  134 +fpathSetBase s fp
  135 + = fp {fpathBase = s}
  136 +
  137 +fpathUpdBase :: (String -> String) -> FPath -> FPath
  138 +fpathUpdBase u fp
  139 + = fp {fpathBase = u (fpathBase fp)}
  140 +
  141 +fpathSetSuff :: String -> FPath -> FPath
  142 +fpathSetSuff "" fp
  143 + = fpathRemoveSuff fp
  144 +fpathSetSuff s fp
  145 + = fp {fpathMbSuff = Just s}
  146 +
  147 +fpathSetNonEmptySuff :: String -> FPath -> FPath
  148 +fpathSetNonEmptySuff "" fp
  149 + = fp
  150 +fpathSetNonEmptySuff s fp
  151 + = fp {fpathMbSuff = Just s}
  152 +
  153 +fpathSetDir :: String -> FPath -> FPath
  154 +fpathSetDir "" fp
  155 + = fpathRemoveDir fp
  156 +fpathSetDir d fp
  157 + = fp {fpathMbDir = Just d}
  158 +
  159 +fpathSplitDirBy :: String -> FPath -> Maybe (String,String)
  160 +fpathSplitDirBy byDir fp
  161 + = do { d <- fpathMbDir fp
  162 + ; dstrip <- stripPrefix byDir' d
  163 + ; return (byDir',filePathUnAbsolute dstrip)
  164 + }
  165 + where byDir' = filePathUnPrefix byDir
  166 +
  167 +fpathPrependDir :: String -> FPath -> FPath
  168 +fpathPrependDir "" fp
  169 + = fp
  170 +fpathPrependDir d fp
  171 + = maybe (fpathSetDir d fp) (\fd -> fpathSetDir (d ++ fpathDirSep ++ fd) fp) (fpathMbDir fp)
  172 +
  173 +fpathUnPrependDir :: String -> FPath -> FPath
  174 +fpathUnPrependDir d fp
  175 + = case fpathSplitDirBy d fp of
  176 + Just (_,d) -> fpathSetDir d fp
  177 + _ -> fp
  178 +
  179 +fpathAppendDir :: FPath -> String -> FPath
  180 +fpathAppendDir fp ""
  181 + = fp
  182 +fpathAppendDir fp d
  183 + = maybe (fpathSetDir d fp) (\fd -> fpathSetDir (fd ++ fpathDirSep ++ d) fp) (fpathMbDir fp)
  184 +
  185 +-- remove common trailing part of dir
  186 +fpathUnAppendDir :: FPath -> String -> FPath
  187 +fpathUnAppendDir fp ""
  188 + = fp
  189 +fpathUnAppendDir fp d
  190 + = case fpathMbDir fp of
  191 + Just p -> fpathSetDir (filePathUnPrefix prefix) fp
  192 + where (prefix,_) = splitAt (length p - length d) p
  193 + _ -> fp
  194 +
  195 +fpathRemoveSuff :: FPath -> FPath
  196 +fpathRemoveSuff fp
  197 + = fp {fpathMbSuff = Nothing}
  198 +
  199 +fpathRemoveDir :: FPath -> FPath
  200 +fpathRemoveDir fp
  201 + = fp {fpathMbDir = Nothing}
  202 +
  203 +splitOnLast :: Char -> String -> Maybe (String,String)
  204 +splitOnLast splitch fn
  205 + = case fn of
  206 + "" -> Nothing
  207 + (f:fs) -> let rem = splitOnLast splitch fs
  208 + in if f == splitch
  209 + then maybe (Just ("",fs)) (\(p,s)->Just (f:p,s)) rem
  210 + else maybe Nothing (\(p,s)->Just (f:p,s)) rem
  211 +
  212 +mkFPathFromDirsFile :: Show s => [s] -> s -> FPath
  213 +mkFPathFromDirsFile dirs f
  214 + = fpathSetDir (concat $ intersperse fpathDirSep $ map show $ dirs) (mkFPath (show f))
  215 +
  216 +mkTopLevelFPath :: String -> String -> FPath
  217 +mkTopLevelFPath suff fn
  218 + = let fpNoSuff = mkFPath fn
  219 + in maybe (fpathSetSuff suff fpNoSuff) (const fpNoSuff) . fpathMbSuff $ fpNoSuff
  220 +
  221 +-------------------------------------------------------------------------------------------
  222 +-- Config
  223 +-------------------------------------------------------------------------------------------
  224 +
  225 +fpathDirSep :: String
  226 +fpathDirSep = "/"
  227 +
  228 +fpathDirSepChar :: Char
  229 +fpathDirSepChar = head fpathDirSep
  230 +
  231 +-------------------------------------------------------------------------------------------
  232 +-- Class 'can make FPath of ...'
  233 +-------------------------------------------------------------------------------------------
  234 +
  235 +class FPATH f where
  236 + mkFPath :: f -> FPath
  237 +
  238 +instance FPATH String where
  239 + mkFPath = fpathFromStr