[commit: ghc] wip/nfs-locking: Add generatePackageCode rule, alexArgs, happyArgs and Hsc2Hs builder. (fdbc3fb)

git at git.haskell.org git at git.haskell.org
Thu Oct 26 23:37:26 UTC 2017


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/fdbc3fba223a2d437954bd0908fdb839fe836ac8/ghc

>---------------------------------------------------------------

commit fdbc3fba223a2d437954bd0908fdb839fe836ac8
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sun Sep 20 02:22:46 2015 +0100

    Add generatePackageCode rule, alexArgs, happyArgs and Hsc2Hs builder.


>---------------------------------------------------------------

fdbc3fba223a2d437954bd0908fdb839fe836ac8
 cfg/system.config.in           |  2 ++
 doc/demo.txt                   |  5 ++++
 src/Builder.hs                 |  2 ++
 src/Rules/Documentation.hs     |  6 ++---
 src/Rules/Generate.hs          | 55 ++++++++++++++++++++++++++++++++++++++++++
 src/Rules/Package.hs           |  2 ++
 src/Settings/Args.hs           | 20 +++++++++------
 src/Settings/Builders/Alex.hs  | 14 +++++++++++
 src/Settings/Builders/Happy.hs | 13 ++++++++++
 9 files changed, 108 insertions(+), 11 deletions(-)

diff --git a/cfg/system.config.in b/cfg/system.config.in
index a274e84..b92b6ba 100644
--- a/cfg/system.config.in
+++ b/cfg/system.config.in
@@ -19,6 +19,8 @@ ghc-cabal      = @hardtop@/inplace/bin/ghc-cabal
 
 haddock        = @hardtop@/inplace/bin/haddock
 
+hsc2hs         = @hardtop@/inplace/bin/hsc2hs
+
 ld             = @LdCmd@
 ar             = @ArCmd@
 alex           = @AlexCmd@
diff --git a/doc/demo.txt b/doc/demo.txt
index 7acd27d..28b3689 100644
--- a/doc/demo.txt
+++ b/doc/demo.txt
@@ -12,3 +12,8 @@
 
 * https://mail.haskell.org/pipermail/ghc-commits/2013-May/001712.html
 * see ghc.mk, comment about parallel ghc-pkg invokations
+
+5. Discovered dead code in the old build system, e.g:
+
+* Alex3 variable not needed as Alex 3.1 is required.
+* There are no generated *.y/*.ly files, hence they can never be in the build directory.
\ No newline at end of file
diff --git a/src/Builder.hs b/src/Builder.hs
index 8e5f639..3a24df3 100644
--- a/src/Builder.hs
+++ b/src/Builder.hs
@@ -26,6 +26,7 @@ data Builder = Alex
              | Haddock
              | Happy
              | HsColour
+             | Hsc2Hs
              | Ld
              deriving (Show, Eq, Generic)
 
@@ -49,6 +50,7 @@ builderKey builder = case builder of
     Happy            -> "happy"
     Haddock          -> "haddock"
     HsColour         -> "hscolour"
+    Hsc2Hs           -> "hsc2hs"
     Ld               -> "ld"
 
 builderPath :: Builder -> Action FilePath
diff --git a/src/Rules/Documentation.hs b/src/Rules/Documentation.hs
index 5978cfd..2ebaa59 100644
--- a/src/Rules/Documentation.hs
+++ b/src/Rules/Documentation.hs
@@ -10,9 +10,9 @@ import Settings
 -- All of them go into the 'doc' subdirectory. Pedantically tracking all built
 -- files in the Shake databases seems fragile and unnecesarry.
 buildPackageDocumentation :: Resources -> PartialTarget -> Rules ()
-buildPackageDocumentation _ target @ (PartialTarget stage pkg) =
-    let cabalFile   = pkgCabalFile pkg
-        haddockFile = pkgHaddockFile pkg
+buildPackageDocumentation _ target @ (PartialTarget stage package) =
+    let cabalFile   = pkgCabalFile package
+        haddockFile = pkgHaddockFile package
     in when (stage == Stage1) $ do
         haddockFile %> \file -> do
             whenM (specified HsColour) $ do
diff --git a/src/Rules/Generate.hs b/src/Rules/Generate.hs
new file mode 100644
index 0000000..055dccb
--- /dev/null
+++ b/src/Rules/Generate.hs
@@ -0,0 +1,55 @@
+module Rules.Generate (generatePackageCode) where
+
+import Expression
+import Oracles
+import Rules.Actions
+import Rules.Resources
+import Settings
+
+-- The following generators and corresponding source extensions are supported:
+knownGenerators :: [ (Builder, String) ]
+knownGenerators =  [ (Alex   , ".x"  )
+                   , (Happy  , ".y"  )
+                   , (Happy  , ".ly" )
+                   , (Hsc2Hs , ".hsc") ]
+
+determineBuilder :: FilePath -> Maybe Builder
+determineBuilder file = fmap fst $ find (\(_, e) -> e == ext) knownGenerators
+  where
+    ext = takeExtension file
+
+generatePackageCode :: Resources -> PartialTarget -> Rules ()
+generatePackageCode _ target @ (PartialTarget stage package) =
+    let path        = targetPath stage package
+        packagePath = pkgPath package
+        buildPath   = path -/- "build"
+    in do
+        buildPath </> "*.hs" %> \file -> do
+            dirs  <- interpretPartial target $ getPkgDataList SrcDirs
+            files <- getDirectoryFiles "" $
+                [ packagePath </> d </> takeBaseName file <.> "*" | d <- dirs ]
+            let gens = [ (f, b) | f <- files, Just b <- [determineBuilder f] ]
+                (src, builder) = head gens
+            when (length gens /= 1) . putError $
+                "Exactly one generator expected for " ++ file
+                ++ "(found: " ++ show gens ++ ")."
+            need [src]
+            build $ fullTarget target builder [src] [file]
+
+-- $1/$2/build/%.hs : $1/$3/%.ly | $$$$(dir $$$$@)/.
+--     $$(call cmd,HAPPY) $$($1_$2_ALL_HAPPY_OPTS) $$< -o $$@
+
+-- $1/$2/build/%.hs : $1/$3/%.y | $$$$(dir $$$$@)/.
+--     $$(call cmd,HAPPY) $$($1_$2_ALL_HAPPY_OPTS) $$< -o $$@
+
+-- $1/$2/build/%_hsc.c $1/$2/build/%_hsc.h $1/$2/build/%.hs : $1/$3/%.hsc $$$$(hsc2hs_INPLACE) | $$$$(dir $$$$@)/.
+--     $$(call cmd,hsc2hs_INPLACE) $$($1_$2_ALL_HSC2HS_OPTS) $$< -o $$@
+
+-- # Now the rules for hs-boot files.
+
+-- $1/$2/build/%.hs-boot : $1/$3/%.hs-boot
+--     "$$(CP)" $$< $$@
+
+-- $1/$2/build/%.lhs-boot : $1/$3/%.lhs-boot
+--     "$$(CP)" $$< $$@
+
diff --git a/src/Rules/Package.hs b/src/Rules/Package.hs
index dfc15e8..9da4f8b 100644
--- a/src/Rules/Package.hs
+++ b/src/Rules/Package.hs
@@ -5,6 +5,7 @@ import Rules.Compile
 import Rules.Data
 import Rules.Dependencies
 import Rules.Documentation
+import Rules.Generate
 import Rules.Library
 import Rules.Resources
 import Target
@@ -13,6 +14,7 @@ buildPackage :: Resources -> PartialTarget -> Rules ()
 buildPackage = mconcat
     [ buildPackageData
     , buildPackageDependencies
+    , generatePackageCode
     , compilePackage
     , buildPackageLibrary
     , buildPackageDocumentation ]
diff --git a/src/Settings/Args.hs b/src/Settings/Args.hs
index 5a8c63a..2e2f379 100644
--- a/src/Settings/Args.hs
+++ b/src/Settings/Args.hs
@@ -1,12 +1,14 @@
 module Settings.Args (getArgs) where
 
 import Expression
+import Settings.Builders.Alex
 import Settings.Builders.Ar
 import Settings.Builders.Gcc
 import Settings.Builders.Ghc
 import Settings.Builders.GhcCabal
 import Settings.Builders.GhcPkg
 import Settings.Builders.Haddock
+import Settings.Builders.Happy
 import Settings.Builders.Ld
 import Settings.User
 
@@ -23,14 +25,16 @@ getArgs = fromDiffExpr $ defaultArgs <> userArgs
 -- TODO: is GhcHcOpts=-Rghc-timing needed?
 defaultArgs :: Args
 defaultArgs = mconcat
-    [ cabalArgs
-    , ghcPkgArgs
-    , ghcMArgs
-    , gccMArgs
-    , ghcArgs
-    , gccArgs
+    [ alexArgs
     , arArgs
-    , ldArgs
+    , cabalArgs
+    , customPackageArgs
+    , ghcArgs
     , ghcCabalHsColourArgs
+    , ghcMArgs
+    , ghcPkgArgs
+    , gccArgs
+    , gccMArgs
     , haddockArgs
-    , customPackageArgs ]
+    , happyArgs
+    , ldArgs ]
diff --git a/src/Settings/Builders/Alex.hs b/src/Settings/Builders/Alex.hs
new file mode 100644
index 0000000..6aedcdb
--- /dev/null
+++ b/src/Settings/Builders/Alex.hs
@@ -0,0 +1,14 @@
+module Settings.Builders.Alex (alexArgs) where
+
+import Expression
+import GHC (compiler)
+import Predicates (builder, package)
+
+alexArgs :: Args
+alexArgs = builder Alex ? do
+    file <- getFile
+    src  <- getSource
+    mconcat [ arg "-g"
+            , package compiler ? arg "--latin1"
+            , arg src
+            , arg "-o", arg file ]
diff --git a/src/Settings/Builders/Happy.hs b/src/Settings/Builders/Happy.hs
new file mode 100644
index 0000000..fcd962a
--- /dev/null
+++ b/src/Settings/Builders/Happy.hs
@@ -0,0 +1,13 @@
+module Settings.Builders.Happy (happyArgs) where
+
+import Expression
+import Predicates (builder)
+
+happyArgs :: Args
+happyArgs = builder Happy ? do
+    file <- getFile
+    src  <- getSource
+    mconcat [ arg "-agc"
+            , arg "--strict"
+            , arg src
+            , arg "-o", arg file ]



More information about the ghc-commits mailing list