-
Notifications
You must be signed in to change notification settings - Fork 23
/
Haskell.hs
151 lines (134 loc) · 5.6 KB
/
Haskell.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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Wrappers for generating prologue and epilogue code in Haskell.
module Data.Aeson.AutoType.CodeGen.Haskell(
writeHaskellModule
, runHaskellModule
, runHaskellModuleStrict
, defaultHaskellFilename
, importedModules
, requiredPackages
, generateModuleImports
, ModuleImport
) where
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Text hiding (unwords)
import qualified Data.HashMap.Strict as Map
import Control.Arrow (first)
import Control.Exception (assert)
import Data.Default
import Data.Monoid ((<>))
import System.FilePath
import System.IO
import System.Process (system)
import qualified System.Environment (lookupEnv)
import System.Exit (ExitCode)
import Data.Aeson.AutoType.Format
import Data.Aeson.AutoType.Type
import Data.Aeson.AutoType.CodeGen.Generic(src)
import Data.Aeson.AutoType.CodeGen.HaskellFormat
import Data.Aeson.AutoType.Util
import qualified Language.Haskell.RunHaskellModule as Run
-- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout).
-- Default module name is consistent with it.
defaultHaskellFilename :: FilePath
defaultHaskellFilename = "JSONTypes.hs"
-- | Generate module header
header :: Text -> Text
header moduleName = [src|
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
-- | DO NOT EDIT THIS FILE MANUALLY!
-- It was automatically generated by `json-autotype`.
module |] <> capitalize moduleName <> [src| where
|] <> generateModuleImports importedModules
-- | Alias for indicating that this is item in module imports list.
type ModuleImport = Text
-- | Given a list of imports, generate source code.
generateModuleImports :: [ModuleImport] -> Text
generateModuleImports = Text.unlines
. fmap ("import " <>)
-- | List of packages required by modules below.
-- Keep and maintain together.
requiredPackages :: [Text]
requiredPackages = ["aeson", "json-alt", "base", "bytestring", "text"]
-- | List of modules to import
importedModules :: [ModuleImport]
importedModules = [
" System.Exit (exitFailure, exitSuccess)"
, " System.IO (stderr, hPutStrLn)"
, "qualified Data.ByteString.Lazy.Char8 as BSL"
, " System.Environment (getArgs)"
, " Control.Monad (forM_, mzero, join)"
, " Control.Applicative"
, " Data.Aeson.AutoType.Alternative"
, " Data.Aeson(eitherDecode, Value(..), FromJSON(..), ToJSON(..),pairs,(.:), (.:?), (.=), object)"
, " Data.Monoid((<>))"
, " Data.Text (Text)"
, "qualified GHC.Generics"
]
-- | Epilogue for generated code:
--
-- * function to use parser to get data from `Text`
-- * main function in case we use `runghc` for testing parser immediately
epilogue :: Text -> Text
epilogue toplevelName = [src|
-- | Use parser to get |] <> toplevelName <> [src| object
parse :: FilePath -> IO |] <> toplevelName <> [src|
parse filename = do
input <- BSL.readFile filename
case eitherDecode input of
Left errTop -> fatal $ case (eitherDecode input :: Either String Value) of
Left err -> "Invalid JSON file: " ++ filename ++ "\n " ++ err
Right _ -> "Mismatched JSON value from file: " ++ filename
++ "\n" ++ errTop
Right r -> return (r :: |] <> toplevelName <> ")" <> [src|
where
fatal :: String -> IO a
fatal msg = do hPutStrLn stderr msg
exitFailure
-- | For quick testing
main :: IO ()
main = do
filenames <- getArgs
forM_ filenames (\f -> parse f >>= (\p -> p `seq` putStrLn $ "Successfully parsed " ++ f))
exitSuccess
|]
-- | Write a Haskell module to an output file, or stdout if `-` filename is given.
writeHaskellModule :: FilePath -> Text -> Map.HashMap Text Type -> IO ()
writeHaskellModule outputFilename toplevelName types =
withFileOrHandle outputFilename WriteMode stdout $ \hOut ->
assert (extension == ".hs") $ do
Text.hPutStrLn hOut $ header $ Text.pack moduleName
-- We write types as Haskell type declarations to output handle
Text.hPutStrLn hOut $ displaySplitTypes types
Text.hPutStrLn hOut $ epilogue toplevelName
where
(moduleName, extension) =
first normalizeTypeName' $
splitExtension $
if outputFilename == "-"
then defaultHaskellFilename
else outputFilename
normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack
-- | Function to run Haskell module
--
-- FIXME: just rely on `run-haskell-module` exports
runHaskellModule :: FilePath -> [String] -> IO ExitCode
runHaskellModule = Run.runHaskellModule
-- | Options to be used when running Haskell module
defaultHaskellOpts :: Run.RunOptions
defaultHaskellOpts = def { Run.additionalPackages = ["json-alt", "aeson"]
}
-- | Run Haskell module with strict warning options (each warning is an error)
runHaskellModuleStrict :: FilePath -> [String] -> IO ExitCode
runHaskellModuleStrict = Run.runHaskellModule' opts
where
opts = def { Run.compileArgs = ["-Wall", "-Werror"]}