/
Setup.hs
125 lines (102 loc) · 4.08 KB
/
Setup.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad.Writer (Writer)
import Data.Functor ((<&>))
import Data.Text (Text)
import Distribution.Simple
import Distribution.Simple.PreProcess
import Distribution.Simple.Utils
import Distribution.Types.BuildInfo (BuildInfo)
import Distribution.Types.LocalBuildInfo (LocalBuildInfo)
import Distribution.Types.ComponentLocalBuildInfo (ComponentLocalBuildInfo)
import System.Directory (getTemporaryDirectory)
import System.IO (hClose)
import Text.Ginger
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.IO as T
main :: IO ()
main = defaultMainWithHooks simpleUserHooks
{ -- override existing extension so Cabal has a file extension it knows already
hookedPreProcessors = [("hsc", ppHscJinja)]
}
ppHscJinja :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ppHscJinja bi lbi clbi = PreProcessor
{ platformIndependent = False
, ppOrdering = unsorted
, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
parsed <- parseGingerFile (fmap Just . readFile) inFile
case parsed of
Left err -> do
source <- readFile inFile
die' verbosity $ formatParserError (Just source) err
Right result -> do
-- put output into a temporary file, then run existing
-- hsc2hs preprocessor on that
tmp <- getTemporaryDirectory
withTempFile tmp "wlhs.hsc" $ \tmpFile handle -> do
debug verbosity $ "HscJinja: got temporary file: " ++ tmpFile
T.hPutStr handle $ easyRender context result
hClose handle -- make sure to finalise everything before hsc2hs reads it
runSimplePreProcessor
(ppHsc2hs bi lbi clbi)
tmpFile outFile verbosity
}
type GVal' = GVal (Run SourcePos (Writer Text) Text)
context :: HM.HashMap Text (GVal')
context = HM.fromList
[ ("struct", fromFunction $ pure . toGVal . mkStruct)
, ("enum", fromFunction $ pure . toGVal . mkEnum)
]
mkStruct :: [(Maybe Text, GVal')] -> Text
mkStruct args = dataDecl <> storableDecl
where
(cfile':ctype':fields') = snd <$> args
cfile = asText cfile'
ctype = asText ctype'
fields = pairs $ asText <$> fields'
hstype =
let (prefix, t) = T.break (=='_') ctype
in T.toUpper prefix <> t
asHsField n = ctype <> "_" <> asField "_" n
asCField n = asField "." n
dataDecl =
T.concat [ "data {-# CTYPE \"" , cfile , "\" \"struct ", ctype, "\" #-} " , hstype]
<> if (null fields')
then ""
else T.concat [" = ", hstype, " { ", recordFields, " }"]
<> " deriving Show"
recordFields = T.intercalate ", " $
fields <&> \(n, t) -> asHsField n <> " :: " <> t
storableDecl
| null fields' = ""
| otherwise =
"\n\ninstance Storable " <> hstype
<> " where\n alignment _ = #alignment struct " <> ctype
<> "\n sizeOf _ = #size struct " <> ctype
<> "\n peek ptr = " <> hstype <> " <$> " <> peekImpl
<> "\n poke ptr t = " <> pokeImpl
peekImpl = T.intercalate " <*> " $
fields <&> \(n, _) ->
"(#peek struct " <> ctype <> ", " <> asCField n <> ") ptr"
pokeImpl = T.intercalate " >> " $
fields <&> \(n, _) ->
"(#poke struct " <> ctype <> ", " <> asCField n
<> ") ptr (" <> asHsField n <> " t)"
mkEnum :: [(Maybe Text, GVal')] -> Text
mkEnum args = enumType <> "\n" <> enumPatterns
where
(hstype':rest') = snd <$> args
hstype = asText hstype'
rest = asText <$> rest'
enumType = "type " <> hstype <> " = CInt"
enumPatterns = T.unlines $
rest >>= \val ->
[ "pattern " <> val <> " :: (Eq a, Num a) => a"
, "pattern " <> val <> " = #const " <> val
]
pairs :: [a] -> [(a, a)]
pairs (a:b:as) = (a,b) : pairs as
pairs _ = []
asField :: Text -> Text -> Text
asField sep = T.intercalate sep . T.words