Skip to content

Commit 777a4cf

Browse files
phadejphadej
committed
Generate Paths module using zinza template
1 parent 7baa972 commit 777a4cf

File tree

7 files changed

+540
-304
lines changed

7 files changed

+540
-304
lines changed

‎Cabal/Cabal.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -603,6 +603,7 @@ library
603603
Distribution.Lex
604604
Distribution.Utils.String
605605
Distribution.Simple.Build.Macros.Z
606+
Distribution.Simple.Build.PathsModule.Z
606607
Distribution.Simple.GHC.EnvironmentParser
607608
Distribution.Simple.GHC.Internal
608609
Distribution.Simple.GHC.ImplInfo

‎Cabal/src/Distribution/Simple/Build/PathsModule.hs

Lines changed: 77 additions & 303 deletions
Large diffs are not rendered by default.

‎Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs

Lines changed: 208 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,208 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where
3+
import Distribution.ZinzaPrelude
4+
data Z
5+
= Z {zPackageName :: PackageName,
6+
zVersionDigits :: String,
7+
zSupportsCpp :: Bool,
8+
zSupportsNoRebindableSyntax :: Bool,
9+
zAbsolute :: Bool,
10+
zRelocatable :: Bool,
11+
zIsWindows :: Bool,
12+
zIsI386 :: Bool,
13+
zIsX8664 :: Bool,
14+
zBindir :: FilePath,
15+
zLibdir :: FilePath,
16+
zDynlibdir :: FilePath,
17+
zDatadir :: FilePath,
18+
zLibexecdir :: FilePath,
19+
zSysconfdir :: FilePath,
20+
zNot :: (Bool -> Bool),
21+
zManglePkgName :: (PackageName -> String)}
22+
deriving Generic
23+
render :: Z -> String
24+
render z_root = execWriter $ do
25+
if (zSupportsCpp z_root)
26+
then do
27+
tell "{-# LANGUAGE CPP #-}\n"
28+
return ()
29+
else do
30+
return ()
31+
if (zSupportsNoRebindableSyntax z_root)
32+
then do
33+
tell "{-# LANGUAGE NoRebindableSyntax #-}\n"
34+
return ()
35+
else do
36+
return ()
37+
if (zNot z_root (zAbsolute z_root))
38+
then do
39+
tell "{-# LANGUAGE ForeignFunctionInterface #-}\n"
40+
return ()
41+
else do
42+
return ()
43+
tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"
44+
tell "module Paths_"
45+
tell (zManglePkgName z_root (zPackageName z_root))
46+
tell " (\n"
47+
tell " version,\n"
48+
tell " getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n"
49+
tell " getDataFileName, getSysconfDir\n"
50+
tell " ) where\n"
51+
tell "\n"
52+
if (zNot z_root (zAbsolute z_root))
53+
then do
54+
tell "import Foreign\n"
55+
tell "import Foreign.C\n"
56+
return ()
57+
else do
58+
return ()
59+
tell "\n"
60+
tell "import qualified Control.Exception as Exception\n"
61+
tell "import Data.Version (Version(..))\n"
62+
tell "import System.Environment (getEnv)\n"
63+
tell "import Prelude\n"
64+
tell "\n"
65+
if (zRelocatable z_root)
66+
then do
67+
tell "import System.Environment (getExecutablePath)\n"
68+
return ()
69+
else do
70+
return ()
71+
tell "\n"
72+
if (zSupportsCpp z_root)
73+
then do
74+
tell "#if defined(VERSION_base)\n"
75+
tell "\n"
76+
tell "#if MIN_VERSION_base(4,0,0)\n"
77+
tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"
78+
tell "#else\n"
79+
tell "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"
80+
tell "#endif\n"
81+
tell "\n"
82+
tell "#else\n"
83+
tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"
84+
tell "#endif\n"
85+
tell "catchIO = Exception.catch\n"
86+
return ()
87+
else do
88+
tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"
89+
tell "catchIO = Exception.catch\n"
90+
return ()
91+
tell "\n"
92+
tell "version :: Version\n"
93+
tell "version = Version "
94+
tell (zVersionDigits z_root)
95+
tell " []\n"
96+
tell "\n"
97+
tell "bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n"
98+
tell "\n"
99+
tell "\n"
100+
if (zRelocatable z_root)
101+
then do
102+
tell "\n"
103+
tell "\n"
104+
return ()
105+
else do
106+
if (zAbsolute z_root)
107+
then do
108+
tell "bindir = "
109+
tell (zBindir z_root)
110+
tell "\n"
111+
tell "libdir = "
112+
tell (zLibdir z_root)
113+
tell "\n"
114+
tell "dynlibdir = "
115+
tell (zDynlibdir z_root)
116+
tell "\n"
117+
tell "datadir = "
118+
tell (zDatadir z_root)
119+
tell "\n"
120+
tell "libexecdir = "
121+
tell (zLibexecdir z_root)
122+
tell "\n"
123+
tell "sysconfdir = "
124+
tell (zSysconfdir z_root)
125+
tell "\n"
126+
tell "\n"
127+
tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"
128+
tell "getBinDir = catchIO (getEnv \""
129+
tell (zManglePkgName z_root (zPackageName z_root))
130+
tell "_bindir\") (\\_ -> return bindir)\n"
131+
tell "getLibDir = catchIO (getEnv \""
132+
tell (zManglePkgName z_root (zPackageName z_root))
133+
tell "_libdir\") (\\_ -> return libdir)\n"
134+
tell "getDynLibDir = catchIO (getEnv \""
135+
tell (zManglePkgName z_root (zPackageName z_root))
136+
tell "_dynlibdir\") (\\_ -> return dynlibdir)\n"
137+
tell "getDataDir = catchIO (getEnv \""
138+
tell (zManglePkgName z_root (zPackageName z_root))
139+
tell "_datadir\") (\\_ -> return datadir)\n"
140+
tell "getLibexecDir = catchIO (getEnv \""
141+
tell (zManglePkgName z_root (zPackageName z_root))
142+
tell "_libexecdir\") (\\_ -> return libexecdir)\n"
143+
tell "getSysconfDir = catchIO (getEnv \""
144+
tell (zManglePkgName z_root (zPackageName z_root))
145+
tell "_sysconfdir\") (\\_ -> return sysconfdir)\n"
146+
tell "\n"
147+
tell "getDataFileName :: FilePath -> IO FilePath\n"
148+
tell "getDataFileName name = do\n"
149+
tell " dir <- getDataDir\n"
150+
tell " return (dir ++ \"/\" ++ name)\n"
151+
return ()
152+
else do
153+
tell "\n"
154+
tell "\n"
155+
return ()
156+
return ()
157+
tell "\n"
158+
if (zNot z_root (zAbsolute z_root))
159+
then do
160+
tell "\n"
161+
tell "minusFileName :: FilePath -> String -> FilePath\n"
162+
tell "minusFileName dir \"\" = dir\n"
163+
tell "minusFileName dir \".\" = dir\n"
164+
tell "minusFileName dir suffix =\n"
165+
tell " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"
166+
tell "\n"
167+
tell "joinFileName :: String -> String -> FilePath\n"
168+
tell "joinFileName \"\" fname = fname\n"
169+
tell "joinFileName \".\" fname = fname\n"
170+
tell "joinFileName dir \"\" = dir\n"
171+
tell "joinFileName dir fname\n"
172+
tell " | isPathSeparator (last dir) = dir++fname\n"
173+
tell " | otherwise = dir++pathSeparator:fname\n"
174+
tell "\n"
175+
tell "splitFileName :: FilePath -> (String, String)\n"
176+
tell "splitFileName p = (reverse (path2++drive), reverse fname)\n"
177+
tell " where\n"
178+
tell " (path,drive) = case p of\n"
179+
tell " (c:':':p') -> (reverse p',[':',c])\n"
180+
tell " _ -> (reverse p ,\"\")\n"
181+
tell " (fname,path1) = break isPathSeparator path\n"
182+
tell " path2 = case path1 of\n"
183+
tell " [] -> \".\"\n"
184+
tell " [_] -> path1 -- don't remove the trailing slash if\n"
185+
tell " -- there is only one character\n"
186+
tell " (c:path') | isPathSeparator c -> path'\n"
187+
tell " _ -> path1\n"
188+
tell "\n"
189+
tell "pathSeparator :: Char\n"
190+
if (zIsWindows z_root)
191+
then do
192+
tell "pathSeparator = '\\\\\\\\'\n"
193+
return ()
194+
else do
195+
tell "pathSeparator = '/'\n"
196+
return ()
197+
tell "\n"
198+
tell "isPathSeparator :: Char -> Bool\n"
199+
if (zIsWindows z_root)
200+
then do
201+
tell "isPathSeparator c = c == '/' || c == '\\\\\\\\'\n"
202+
return ()
203+
else do
204+
tell "isPathSeparator c = c == '/'\n"
205+
return ()
206+
return ()
207+
else do
208+
return ()

‎Makefile

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -50,12 +50,16 @@ $(SPDX_EXCEPTION_HS) : templates/SPDX.LicenseExceptionId.template.hs cabal-dev-s
5050
# source generation: templates
5151

5252
TEMPLATE_MACROS:=Cabal/src/Distribution/Simple/Build/Macros/Z.hs
53+
TEMPLATE_PATHS:=Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
5354

54-
templates : phony $(TEMPLATE_MACROS)
55+
templates : phony $(TEMPLATE_MACROS) $(TEMPLATE_PATHS)
5556

5657
$(TEMPLATE_MACROS) : templates/cabal_macros.template.h cabal-dev-scripts/src/GenCabalMacros.hs
5758
cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-cabal-macros -- $< $@
5859

60+
$(TEMPLATE_PATHS) : templates/Paths_pkg.template.hs cabal-dev-scripts/src/GenPathsModule.hs
61+
cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-paths-module -- $< $@
62+
5963
# generated docs
6064

6165
buildinfo-fields-reference : phony

‎cabal-dev-scripts/cabal-dev-scripts.cabal

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -93,6 +93,20 @@ executable gen-cabal-macros
9393
, template-haskell
9494
, zinza ^>=0.2
9595

96+
executable gen-paths-module
97+
default-language: Haskell2010
98+
main-is: GenPathsModule.hs
99+
other-modules: Capture
100+
hs-source-dirs: src
101+
ghc-options: -Wall
102+
build-depends:
103+
, base
104+
, bytestring
105+
, Cabal
106+
, syb ^>=0.7.1
107+
, template-haskell
108+
, zinza ^>=0.2
109+
96110
executable gen-cabal-install-cabal
97111
default-language: Haskell2010
98112
main-is: GenCabalInstallCabal.hs

‎cabal-dev-scripts/src/GenPathsModule.hs

Lines changed: 103 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE TemplateHaskell #-}
5+
{-# OPTIONS_GHC -Wno-orphans #-}
6+
module Main (main) where
7+
8+
import Control.Exception (SomeException (..), catch, displayException)
9+
import Distribution.Types.PackageName (PackageName)
10+
import Distribution.Types.Version (Version)
11+
import GHC.Generics (Generic)
12+
import System.Environment (getArgs)
13+
import System.Exit (exitFailure)
14+
import Zinza
15+
(ModuleConfig (..), Ty (..), Zinza (..), genericFromValueSFP, genericToTypeSFP,
16+
genericToValueSFP, parseAndCompileModuleIO)
17+
18+
import Capture
19+
20+
-------------------------------------------------------------------------------
21+
-- Inputs
22+
-------------------------------------------------------------------------------
23+
24+
$(capture "decls" [d|
25+
data Z = Z
26+
{ zPackageName :: PackageName
27+
, zVersionDigits :: String
28+
, zSupportsCpp :: Bool
29+
, zSupportsNoRebindableSyntax :: Bool
30+
, zAbsolute :: Bool
31+
, zRelocatable :: Bool
32+
, zIsWindows :: Bool
33+
, zIsI386 :: Bool
34+
, zIsX8664 :: Bool
35+
36+
37+
, zBindir :: FilePath
38+
, zLibdir :: FilePath
39+
, zDynlibdir :: FilePath
40+
, zDatadir :: FilePath
41+
, zLibexecdir :: FilePath
42+
, zSysconfdir :: FilePath
43+
44+
, zNot :: Bool -> Bool
45+
, zManglePkgName :: PackageName -> String
46+
}
47+
deriving (Generic)
48+
|])
49+
50+
-------------------------------------------------------------------------------
51+
-- Main
52+
-------------------------------------------------------------------------------
53+
54+
withIO :: (FilePath -> FilePath -> IO a) -> IO a
55+
withIO k = do
56+
args <- getArgs
57+
case args of
58+
[src,tgt] -> k src tgt `catch` \(SomeException e) -> do
59+
putStrLn $ "Exception: " ++ displayException e
60+
exitFailure
61+
_ -> do
62+
putStrLn "Usage cabal v2-run ... source.temeplate.ext target.ext"
63+
exitFailure
64+
65+
main :: IO ()
66+
main = withIO $ \src tgt -> do
67+
mdl <- parseAndCompileModuleIO config src
68+
writeFile tgt mdl
69+
70+
config :: ModuleConfig Z
71+
config = ModuleConfig
72+
{ mcRender = "render"
73+
, mcHeader =
74+
[ "{-# LANGUAGE DeriveGeneric #-}"
75+
, "module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where"
76+
, "import Distribution.ZinzaPrelude"
77+
, decls
78+
, "render :: Z -> String"
79+
]
80+
}
81+
82+
-------------------------------------------------------------------------------
83+
-- Zinza instances
84+
-------------------------------------------------------------------------------
85+
86+
instance Zinza Z where
87+
toType = genericToTypeSFP
88+
toValue = genericToValueSFP
89+
fromValue = genericFromValueSFP
90+
91+
-------------------------------------------------------------------------------
92+
-- Orphans
93+
-------------------------------------------------------------------------------
94+
95+
instance Zinza PackageName where
96+
toType _ = TyString (Just "prettyShow")
97+
toValue _ = error "not needed"
98+
fromValue _ = error "not needed"
99+
100+
instance Zinza Version where
101+
toType _ = TyString (Just "prettyShow")
102+
toValue _ = error "not needed"
103+
fromValue _ = error "not needed"

0 commit comments

Comments
 (0)