preprocess-haskell (empty) → 0.0.1.0

raw patch · 7 files changed

+610/−0 lines, 7 filesdep +Cabaldep +basedep +base-unicode-symbolssetup-changed

Dependencies added: Cabal, base, base-unicode-symbols, basic-prelude, bytestring, containers, cpphs, deepseq, directory, file-embed, foldl, haskell-src-exts, here, system-filepath, temporary, text, turtle, unix

Files

LICENSE +31/−0
Setup.hs +2/−0
preprocess-haskell.cabal +40/−0
src/Language/Haskell/Preprocess.hs +14/−0
src/Language/Haskell/Preprocess/Examples.hs +59/−0
src/Language/Haskell/Preprocess/Internal.hs +436/−0
src/Language/Haskell/Preprocess/Macros.hs +28/−0

+ LICENSE view

@@ -0,0 +1,31 @@+Copyright (c) 2015 Sourcegraph, Inc.++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.++    * Neither the name of Don Stewart nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ preprocess-haskell.cabal view

@@ -0,0 +1,40 @@+name:                preprocess-haskell+version:             0.0.1.0+synopsis:            Preprocess Haskell Repositories.+license:             BSD3+license-file:        LICENSE+author:              Benjamin Summers+maintainer:          ben@benjaminsummers.net+category:            Language+build-type:          Simple+description:         Do all of the dirty work required to get a Haskell repo+                     ready for straightforward static-analysis.+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/sourcegraph/preprocess-haskell.git++source-repository this+  type:     git+  location: https://github.com/sourcegraph/preprocess-haskell.git+  tag:      preprocess-haskell-0.0.1.0++library+  hs-source-dirs:      src+  ghc-options:         -Wall+  default-language:    Haskell2010+  default-extensions:  NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables+                     , UnicodeSyntax++  build-depends:       base >=4.7 && <4.8, foldl, system-filepath, turtle,+                       basic-prelude, cpphs, containers,+                       base-unicode-symbols, text, Cabal, temporary, unix,+                       deepseq, file-embed, bytestring, haskell-src-exts,+                       directory, here++  exposed-modules:     Language.Haskell.Preprocess+                     , Language.Haskell.Preprocess.Internal+                     , Language.Haskell.Preprocess.Examples++  other-modules:       Language.Haskell.Preprocess.Macros

+ src/Language/Haskell/Preprocess.hs view

@@ -0,0 +1,14 @@+module Language.Haskell.Preprocess (+ ModuleName(..), SrcTreePath, Pkg,+ unSTP,stFile,stDir,stpStr,+ pkgRoot,pkgCabalFile,pkgModules,pkgMacros,pkgIncludeDirs,pkgDefaultExtensions,+ directoriesThatRequireAutotoolsConfiguration,+ configureWithAutotools,configureWithAutotoolsRecursive,+ analyseCopy,analyseConfiguredCopy,+ scan,+ scanPkg,+ processFile,+ parseCode)+where++import Language.Haskell.Preprocess.Internal

+ src/Language/Haskell/Preprocess/Examples.hs view

@@ -0,0 +1,59 @@+module Language.Haskell.Preprocess.Examples where+++import BasicPrelude hiding (forM, forM_, mapM, mapM_, sum)++import qualified Prelude++import Control.DeepSeq+import Data.Foldable+import Data.Map.Strict  as M+import Data.Set         as S+import Data.Traversable++import Language.Haskell.Exts.Annotated as HSE hiding (ModuleName)++import Language.Haskell.Preprocess+++type EntireProject a = Map SrcTreePath (Pkg, Map ModuleName a)+type MaybeModule = Maybe(Module SrcSpanInfo)++-- | TODO This is poorly thought out.+type Transform a = Pkg → FilePath → String → a++loadPkg ∷ NFData a ⇒+            FilePath → Transform a → SrcTreePath →+              IO (Pkg,Map ModuleName a)+loadPkg root transform pkgFile = do+  pkg ← scanPkg root pkgFile+  sources ← forM (pkgModules pkg) $ \fp →+    processFile root pkg (transform pkg $ unSTP fp) fp+  return (pkg,sources)++loadEntireProject ∷ NFData a ⇒ FilePath → Transform a → IO (EntireProject a)+loadEntireProject root transform = do+  pkgFiles ← S.toList <$> scan root+  mapM (loadPkg root transform) $ M.fromList $ (\x→(x,x)) <$> pkgFiles++parseEntireProject ∷ FilePath → IO (EntireProject MaybeModule)+parseEntireProject root = do+  pkgFiles ← S.toList <$> scan root+  mapM (loadPkg root parseCode) $ M.fromList $ (\x→(x,x)) <$> pkgFiles++listFiles ∷ FilePath → IO [FilePath]+listFiles root = do+  pkgFiles ← S.toList <$> scan root+  fmap (fmap unSTP . join) $ forM pkgFiles $ \pkgFile →+    M.elems . pkgModules <$> scanPkg root pkgFile++loc ∷ FilePath → IO Int+loc root = do+  pkgFiles ← S.toList <$> scan root+  fmap sum $ forM pkgFiles $ \pkgFile → do+    pkg ← scanPkg root pkgFile+    sum <$> forM (M.elems (pkgModules pkg))+              (processFile root pkg (length . Prelude.lines))++configureAndParseEntireProject ∷ FilePath → IO (EntireProject MaybeModule)+configureAndParseEntireProject = flip analyseConfiguredCopy parseEntireProject

+ src/Language/Haskell/Preprocess/Internal.hs view

@@ -0,0 +1,436 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-}++module Language.Haskell.Preprocess.Internal where+++-- Imports -------------------------------------------------------------------++import BasicPrelude hiding (Map, empty, find, forM, mapM, show)+import Turtle       hiding (e, fp, root, x)++import           Control.Category.Unicode+import           Debug.Trace+import           Prelude                  (show)+import qualified Prelude+import           Prelude.Unicode+import           Text.Printf+++import Language.Haskell.Exts.Annotated as HSE hiding (ModuleName, fileName,+                                               mode)++import           Control.DeepSeq+import qualified Control.Exception+import qualified Control.Foldl             as Fold+import qualified Data.ByteString           as BS+import           Data.Map.Strict           (Map)+import qualified Data.Map.Strict           as M+import qualified Data.Set                  as S+import qualified Data.Text                 as T+import qualified Filesystem.Path.CurrentOS as P++import qualified Language.Preprocessor.Cpphs as CPP++import qualified System.IO.Temp as IO++import qualified Distribution.Package                          as C+import qualified Distribution.PackageDescription               as C+import qualified Distribution.PackageDescription.Configuration as C+import qualified Distribution.PackageDescription.Parse         as C+import qualified Distribution.Simple.Build.Macros              as C+import qualified Distribution.Verbosity                        as C+import qualified Distribution.Version                          as C+import qualified Language.Haskell.Extension                    as C++import Language.Haskell.Preprocess.Macros+++-- Types ---------------------------------------------------------------------++newtype ModuleName = MN { unModuleName ∷ Text }+  deriving (Eq,Ord,IsString,Show)++-- | Path's relative to the root of the source tree.+newtype SrcTreePath = SrcTreePath { unSTP ∷ P.FilePath }+  deriving (Eq,Ord,IsString,Show,NFData)++-- TODO Consider writing a newtype for CabalFile+-- TODO Consider writing a newtype for HSFile+-- TODO Consider writing a newtype for SrcDir++data Pkg = Pkg {+  pkgRoot              ∷ !SrcTreePath,+  pkgCabalFile         ∷ !SrcTreePath,+  pkgModules           ∷ !(Map ModuleName SrcTreePath),+  pkgMacros            ∷ !String,+  pkgIncludeDirs       ∷ ![SrcTreePath],+  pkgDefaultExtensions ∷ ![C.Extension]+}+++-- Typeclass Instances -------------------------------------------------------++-- TODO This is highly questionable.+instance NFData C.Extension+instance NFData SrcSpanInfo+instance NFData a ⇒ NFData (Module a)+++-- Utilities for Dealing with FilePath's -------------------------------------++pathStr ∷ FilePath → String+pathStr = P.encodeString++mkAbsolute ∷ FilePath → IO FilePath+mkAbsolute fp = if P.absolute fp+                  then return fp+                  else do wd ← pwd+                          return $ P.collapse $ wd <> fp++fileP ∷ P.FilePath → P.FilePath+fileP fp = if fp≠P.directory fp then fp else+            error $ printf "%s is not a path to a file." (show fp)++normalizeP ∷ P.FilePath → P.FilePath+normalizeP fp =+  if P.relative fp then P.collapse $ "./" <> fp else+    error $ printf "`stp` called on absolute path: %s" (show fp)++stFile ∷ P.FilePath → SrcTreePath+stFile = SrcTreePath . normalizeP . fileP++stDir ∷ P.FilePath → SrcTreePath+stDir = SrcTreePath . normalizeP . (<> "")++stpStr ∷ SrcTreePath → String+stpStr = pathStr . unSTP+++-- Values --------------------------------------------------------------------++cabalFiles ∷ Pattern Text+cabalFiles = suffix ".cabal"++haskellFiles ∷ Pattern Text+haskellFiles = suffix ".hs" <|> suffix ".lhs"++consFold ∷ Fold a [a]+consFold = Fold.Fold (flip (:)) [] reverse++shellLines ∷ Shell a → IO [a]+shellLines = flip fold consFold++literateHaskellFilename ∷ P.FilePath → Bool+literateHaskellFilename fp = Just "lhs" ≡ P.extension fp++hackAroundCPPHSFlaws ∷ String → String+hackAroundCPPHSFlaws = T.pack+     ⋙ T.replace "defined(MIN_VERSION_hashable)" "1"+     ⋙ T.replace "defined(MIN_VERSION_integer_gmp)" "1"+     ⋙ T.unpack++prToMaybe ∷ ParseResult a → Maybe a+prToMaybe (ParseOk x) = Just x+prToMaybe (ParseFailed l c) =+  flip trace Nothing $ printf "Parse failed! %s %s" (show l) (show c)++cvtKExt ∷ C.KnownExtension → Maybe KnownExtension+cvtKExt e = case e of+  C.OverlappingInstances → Just OverlappingInstances+  C.UndecidableInstances → Just UndecidableInstances+  C.IncoherentInstances → Just IncoherentInstances+  C.InstanceSigs → Just InstanceSigs+  C.DoRec → Just DoRec+  C.RecursiveDo → Just RecursiveDo+  C.ParallelListComp → Just ParallelListComp+  C.MultiParamTypeClasses → Just MultiParamTypeClasses+  C.MonomorphismRestriction → Just MonomorphismRestriction+  C.FunctionalDependencies → Just FunctionalDependencies+  C.Rank2Types → Just Rank2Types+  C.RankNTypes → Just RankNTypes+  C.PolymorphicComponents → Just PolymorphicComponents+  C.ExistentialQuantification → Just ExistentialQuantification+  C.ScopedTypeVariables → Just ScopedTypeVariables+  C.PatternSignatures → Just PatternSignatures+  C.ImplicitParams → Just ImplicitParams+  C.FlexibleContexts → Just FlexibleContexts+  C.FlexibleInstances → Just FlexibleInstances+  C.EmptyDataDecls → Just EmptyDataDecls+  C.CPP → Just CPP+  C.KindSignatures → Just KindSignatures+  C.BangPatterns → Just BangPatterns+  C.TypeSynonymInstances → Just TypeSynonymInstances+  C.TemplateHaskell → Just TemplateHaskell+  C.ForeignFunctionInterface → Just ForeignFunctionInterface+  C.Arrows → Just Arrows+  C.Generics → Just Generics+  C.ImplicitPrelude → Just ImplicitPrelude+  C.NamedFieldPuns → Just NamedFieldPuns+  C.PatternGuards → Just PatternGuards+  C.GeneralizedNewtypeDeriving → Just GeneralizedNewtypeDeriving+  C.ExtensibleRecords → Just ExtensibleRecords+  C.RestrictedTypeSynonyms → Just RestrictedTypeSynonyms+  C.HereDocuments → Just HereDocuments+  C.MagicHash → Just MagicHash+  C.TypeFamilies → Just TypeFamilies+  C.StandaloneDeriving → Just StandaloneDeriving+  C.UnicodeSyntax → Just UnicodeSyntax+  C.UnliftedFFITypes → Just UnliftedFFITypes+  C.LiberalTypeSynonyms → Just LiberalTypeSynonyms+  C.TypeOperators → Just TypeOperators+  C.ParallelArrays → Just ParallelArrays+  C.RecordWildCards → Just RecordWildCards+  C.RecordPuns → Just RecordPuns+  C.DisambiguateRecordFields → Just DisambiguateRecordFields+  C.OverloadedStrings → Just OverloadedStrings+  C.GADTs → Just GADTs+  C.MonoPatBinds → Just MonoPatBinds+  C.RelaxedPolyRec → Just RelaxedPolyRec+  C.ExtendedDefaultRules → Just ExtendedDefaultRules+  C.UnboxedTuples → Just UnboxedTuples+  C.DeriveDataTypeable → Just DeriveDataTypeable+  C.ConstrainedClassMethods → Just ConstrainedClassMethods+  C.PackageImports → Just PackageImports+  C.LambdaCase → Just LambdaCase+  C.ImpredicativeTypes → Just ImpredicativeTypes+  C.NewQualifiedOperators → Just NewQualifiedOperators+  C.PostfixOperators → Just PostfixOperators+  C.QuasiQuotes → Just QuasiQuotes+  C.TransformListComp → Just TransformListComp+  C.ViewPatterns → Just ViewPatterns+  C.XmlSyntax → Just XmlSyntax+  C.RegularPatterns → Just RegularPatterns+  C.TupleSections → Just TupleSections+  C.GHCForeignImportPrim → Just GHCForeignImportPrim+  C.NPlusKPatterns → Just NPlusKPatterns+  C.DoAndIfThenElse → Just DoAndIfThenElse+  C.RebindableSyntax → Just RebindableSyntax+  C.ExplicitForAll → Just ExplicitForAll+  C.DatatypeContexts → Just DatatypeContexts+  C.MonoLocalBinds → Just MonoLocalBinds+  C.DeriveFunctor → Just DeriveFunctor+  C.DeriveGeneric → Just DeriveGeneric+  C.DeriveTraversable → Just DeriveTraversable+  C.DeriveFoldable → Just DeriveFoldable+  C.NondecreasingIndentation → Just NondecreasingIndentation+  C.InterruptibleFFI → Just InterruptibleFFI+  C.CApiFFI → Just CApiFFI+  C.ExplicitNamespaces → Just ExplicitNamespaces+  C.DataKinds → Just DataKinds+  C.PolyKinds → Just PolyKinds+  C.MultiWayIf → Just MultiWayIf+  C.SafeImports → Just SafeImports+  C.Safe → Just Safe+  C.Trustworthy → Just Trustworthy+  C.DefaultSignatures → Just DefaultSignatures+  C.ConstraintKinds → Just ConstraintKinds+  _ → flip trace Nothing $ printf "Unknown Extension: %s" (show e)++maybeUnknown ∷ C.KnownExtension → Maybe Extension → Extension+maybeUnknown x = fromMaybe $ UnknownExtension $ show x++cvtExt ∷ C.Extension → Extension+cvtExt (C.EnableExtension x)   = maybeUnknown x (EnableExtension  <$> cvtKExt x)+cvtExt (C.DisableExtension x)  = maybeUnknown x (DisableExtension <$> cvtKExt x)+cvtExt (C.UnknownExtension nm) = UnknownExtension nm++extensionsHack ∷ [Extension]+extensionsHack =+  [ EnableExtension NPlusKPatterns+  , EnableExtension ExplicitForAll+  , EnableExtension FlexibleContexts+  , EnableExtension ExplicitNamespaces+  , EnableExtension CPP+  , EnableExtension MagicHash+  , EnableExtension TemplateHaskell+  , EnableExtension MultiParamTypeClasses+  , EnableExtension ExistentialQuantification+  ]++-- | BE CAREFUL! This updates the filesystem at `fp` and depends on autoreconf.+-- TODO write proper code for having a temporary working directory.+configureWithAutotools ∷ FilePath → IO ()+configureWithAutotools fp = do+  wd ← pwd+  cd fp+  traceM "running autoreconf"+  sh $ inshell "autoreconf" empty+  traceM "running ./configure"+  sh $ inshell "./configure" empty+  cd wd++directoriesThatRequireAutotoolsConfiguration ∷ FilePath → IO [FilePath]+directoriesThatRequireAutotoolsConfiguration fp =+  map P.directory <$> shellLines (find (has "configure.ac") fp)++sourceTreeDependsOnAutotools ∷ FilePath → IO Bool+sourceTreeDependsOnAutotools fp = do+  dirs ← directoriesThatRequireAutotoolsConfiguration fp+  return $ 0 ≠ length dirs++configureWithAutotoolsRecursive ∷ FilePath → IO ()+configureWithAutotoolsRecursive fp = do+  dirs ← directoriesThatRequireAutotoolsConfiguration fp+  forM_ dirs configureWithAutotools++analyseCopy ∷ FilePath → (FilePath → IO a) → IO a+analyseCopy fp analyse =+  IO.withSystemTempDirectory "copy_for_analysis" $ \tmpDir → do+   fpstr ← pathStr <$> mkAbsolute fp+   let cmd = printf "(cd '%s'; tar c .) | (cd '%s'; tar x)" fpstr tmpDir+   traceM "copying project to a temporary directory"+   sh $ inshell (T.pack cmd) empty+   traceM "done copying"+   analyse $ P.decodeString tmpDir++analyseConfiguredCopy ∷ FilePath → (FilePath → IO a) → IO a+analyseConfiguredCopy fp analyse =+  analyseCopy fp $ \tmpDir → do+    configureWithAutotoolsRecursive tmpDir+    analyse tmpDir++parseCode ∷ Pkg → FilePath → String → Maybe (Module SrcSpanInfo)+parseCode pkg filePath source = do+  let fileName = pathStr filePath+  let mode = defaultParseMode+        { parseFilename     = fileName+        , fixities          = Nothing+        , ignoreLinePragmas = False+        , extensions        = extensionsHack+                           ++ (cvtExt <$> pkgDefaultExtensions pkg)+                           ++ extensions defaultParseMode+        }+  prToMaybe $ parseFileContentsWithMode mode source++catchAny ∷ IO a → (SomeException → IO a) → IO a+catchAny = Control.Exception.catch++-- TODO This uses deepseq to avoid issues related to lazy IO. I feel+--      like that's a bad idea.+processFile ∷ NFData a ⇒ FilePath → Pkg → (String → a) → SrcTreePath → IO a+processFile root' pkg transform fn = do+  let root = root' <> "" -- Forces root to be a directory path.+  let warn e = do+        traceM $ printf "Ignoring exception: %s" $ show e+        return $ transform ""++  flip catchAny warn $+    IO.withSystemTempDirectory "cpp_macros" $ \tmpDir → do+      let tmpDirFP         = P.decodeString tmpDir+          cabalMacrosFP    = tmpDirFP </> "cabal_macros.h"+          compilerMacrosFP = tmpDirFP </> "ghc_macros.h"++      writeFile cabalMacrosFP    $ T.pack (pkgMacros pkg)+      writeFile compilerMacrosFP $ T.pack compilerMacros+      forM_ (M.toList stdHdrs) $ \(hdrFileName,hdrContents) → do+        let absPath = tmpDirFP </> hdrFileName+        mktree (P.parent absPath)+        BS.writeFile (pathStr absPath) hdrContents++      let pstr = pathStr (P.collapse $ root </> unSTP fn)+      contents ← hackAroundCPPHSFlaws <$> Prelude.readFile pstr++      let pkgIncludes =+            pathStr . P.collapse . (root </>) . unSTP+              <$> pkgIncludeDirs pkg++      let defaults = CPP.defaultCpphsOptions+          cppOpts = defaults {+            CPP.preInclude = pathStr <$> [compilerMacrosFP, cabalMacrosFP],+            CPP.includes = pkgIncludes ++ [tmpDir],+            CPP.boolopts = (CPP.boolopts defaults) {+              CPP.hashline = False,+              CPP.stripC89 = True,+              CPP.warnings = True,+              CPP.literate = literateHaskellFilename(unSTP fn) }}+      noMacros ← CPP.runCpphs cppOpts pstr contents+      let result = transform noMacros+      result `deepseq` return result++moduleName ∷ [SrcTreePath] → SrcTreePath → Maybe ModuleName+moduleName srcDirs fn = listToMaybe moduleNames+    where tryPrefix = flip P.stripPrefix $ unSTP fn+          pathToModule = P.splitDirectories+                       ⋙ fmap (T.filter (≠'/') . T.pack . pathStr)+                       ⋙ T.intercalate "."+                       ⋙ MN+          moduleNames = pathToModule . P.dropExtensions <$> pathNames+          pathNames = catMaybes $ tryPrefix . unSTP <$> srcDirs++-- TODO This is terrible. Rewrite this.+allSourceDirs ∷ C.PackageDescription → [String]+allSourceDirs desc = nub $ join $ libDirs ++ exeDirs+  where+     libDirs = maybeToList (C.hsSourceDirs . C.libBuildInfo <$> C.library desc)+     exeDirs = C.hsSourceDirs . C.buildInfo <$> C.executables desc++-- TODO This is terrible. Rewrite this.+allHeaderIncludeDirs ∷ C.PackageDescription → [String]+allHeaderIncludeDirs desc = nub $ join $ libDirs ++ exeDirs+  where+     libDirs = maybeToList (C.includeDirs . C.libBuildInfo <$> C.library desc)+     exeDirs = C.includeDirs . C.buildInfo <$> C.executables desc++-- TODO This is terrible. Rewrite this.+allDefaultExtensions ∷ C.PackageDescription → [C.Extension]+allDefaultExtensions desc = nub $ join $ libDirs ++ exeDirs+  where+     libDirs = maybeToList (C.defaultExtensions . C.libBuildInfo <$> C.library desc)+     exeDirs = C.defaultExtensions . C.buildInfo <$> C.executables desc++-- `chooseVersion` chooses the greatest version that is explicitly+-- mentioned, but uses 0.1.0.0 if none is mentioned.+chooseVersion ∷ C.VersionRange → C.Version+chooseVersion = C.foldVersionRange fallback id id id max max+  where fallback = C.Version [0,1,0,0] []++pkgDeps ∷ C.GenericPackageDescription → [C.Dependency]+pkgDeps = C.buildDepends . C.flattenPackageDescription++cabalMacros ∷ C.GenericPackageDescription → String+cabalMacros = C.generatePackageVersionMacros . pkgs+  where resolve (C.Dependency n v) = C.PackageIdentifier n $ chooseVersion v+        pkgs = fmap resolve . pkgDeps++cabalInfo ∷ FilePath → SrcTreePath → IO ([SrcTreePath],String,[SrcTreePath],[C.Extension])+cabalInfo root' cabalFile = do+  let root = root' <> "" -- Forces root to be a directory path.+  traceM $ "scanning pakage: " <> stpStr cabalFile+  let cabalFileStr = pathStr $ root <> unSTP cabalFile+  gdesc ← C.readPackageDescription C.normal cabalFileStr+  let desc        = C.flattenPackageDescription gdesc+      rootOfPkg   = directory $ unSTP cabalFile+      dirStrs     = allSourceDirs desc+      incDirs     = allHeaderIncludeDirs desc+      exts        = allDefaultExtensions desc+      toSTP       = stDir . (rootOfPkg <>) . P.decodeString+      macros      = cabalMacros gdesc++  let result = (toSTP <$> dirStrs, macros, toSTP <$> incDirs, exts)+  result `deepseq` return result++scanPkg ∷ FilePath → SrcTreePath → IO Pkg+scanPkg root' cabalFile = do+  let root = root' <> "" -- Forces root to be a directory path.+  let pkgDir = stDir $ P.directory $ unSTP cabalFile++  hsFiles' ← shellLines (find haskellFiles $ root <> unSTP pkgDir)+  (srcDirs,macros,includeDirs,defaultExtensions) ← cabalInfo root cabalFile++  let hsFiles = flip map hsFiles' $ \x →+        let dieWithError = error $ printf "%s is not a prefix of %s!"+                             (pathStr root) (pathStr x)+        in stFile $ fromMaybe dieWithError $ P.stripPrefix root $ P.collapse x+      modules = M.fromList $ catMaybes $ flip map hsFiles $ \hs →+        (,hs) <$> moduleName srcDirs hs++  return $ Pkg pkgDir cabalFile modules macros includeDirs defaultExtensions++scan ∷ FilePath → IO (Set SrcTreePath)+scan root' = do+  let root = root' <> "" -- Forces root to be a directory path.+  packageFiles ← shellLines $ find cabalFiles root+  return $ S.fromList $ flip map packageFiles $ \x →+    let dieWithError = error $ printf "%s is not a prefix of %s!"+                         (pathStr root) (pathStr x)+    in stFile $ fromMaybe dieWithError $ P.stripPrefix root $ P.collapse x

+ src/Language/Haskell/Preprocess/Macros.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}++module Language.Haskell.Preprocess.Macros(compilerMacros,stdHdrs) where++import Prelude++import Data.FileEmbed+import Data.String.Here++import           Control.Arrow+import qualified Data.ByteString           as BS+import qualified Data.Map                  as M+import qualified Filesystem.Path           as P+import qualified Filesystem.Path.CurrentOS as P++stdHdrs ∷ M.Map P.FilePath BS.ByteString+stdHdrs = M.fromList $ map (first P.decodeString) $(embedDir "include")++compilerMacros ∷ String+compilerMacros = x++"\n" where x = [here|+#define __GLASGOW_HASKELL__ 708+#define x86_64_HOST_ARCH 1+#define linux_HOST_OS 1+#define mingw32_HOST_OS 1+#define FLT_RADIX 2+#define HAVE_POLL 1+#define INTEGER_GMP 1+|]