-
Notifications
You must be signed in to change notification settings - Fork 0
/
maincodegenerator.hs
212 lines (208 loc) · 12 KB
/
maincodegenerator.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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
{-|
Module : MainCodeGenerator
Description : Generates the code for the entry point of the compiler.
Copyright : (c) Samuel Williams, 2021
License : GPL-3
Maintainer : samuel.will1999@gmail.com
Stability : release
The code generated by this file handles all the IO actions for the generate compiler, and acts as the entry point.
This code will differ greatly depending on whether or not includes are supported, since the majority of the handling for this feature is within this file.
The IO actions supported by this file include argument and flag handling for command-line use, input and output file path specification, and verbose command-line output.
-}
module MainCodeGenerator (generateMainCode) where
-- | This function returns the entire compiler main file, and cannot fail.
generateMainCode :: String -- ^ Parser module name
-> String -- ^ Semantics module name
-> String -- ^ Input file extension
-> Bool -- ^ Whether or not the generated compiler supports includes
-> String -- ^ The main compiler code
generateMainCode parserModule semanticsModule ext hasIncludes = unlines $ [
"module Main where",
"import System.IO",
"import System.Directory",
"import System.Environment",
"import System.FilePath.Posix",
"import System.Console.GetOpt",
"import System.Exit",
"import Data.HashMap.Strict as Map",
"import Data.List as List hiding (insert, delete)",
"import Data.Ord",
"import Data.Maybe (fromMaybe)",
"import Data.Foldable (asum)",
"import Data.Time",
"import Data.Time.Format",
"import " ++ parserModule,
"import " ++ semanticsModule,
"data Flag = Ext | Info | Verbose | Output String " ++ (if hasIncludes then "| Dep String " else "") ++ "deriving (Show, Eq)",
"options :: [OptDescr Flag]",
"options = [ Option ['e'] [\"ext\", \"extension\"] (NoArg Ext) \"input extension for this compiler\"",
" , Option ['v'] [\"verbose\"] (NoArg Verbose) \"extra output information\"",
" , Option ['i'] [\"info\"] (NoArg Info) \"information about this compiler\"",
" , Option ['o'] [\"output\", \"out\"] (ReqArg Output \"FILE\") \"output FILE\"",
if hasIncludes then " , Option ['d'] [\"dep\", \"dependency\"] (ReqArg Dep \"DIR\") \"dependency folder\" ]" else " ]",
"handleArgs :: [String] -> IO ([Flag], [String])",
"handleArgs argv =",
" case getOpt Permute options argv of",
" (fs,args,[]) -> return (fs, args)",
" (_,_,errs) -> usageError errs",
"usageError :: [String] -> IO a",
"usageError errs = ioError (userError (concat errs ++ usageInfo header options))",
" where header = \"\\nUsage: " ++ ext ++ "compiler [OPTION...] FILE\"",
"getOutputPath :: [Flag] -> Maybe String",
"getOutputPath [] = Nothing",
"getOutputPath ((Output s):fs) = Just s",
"getOutputPath (_:fs) = getOutputPath fs",
"logV :: Bool -> String -> IO ()",
"logV False _ = return ()",
"logV True s = do",
" t <- getZonedTime",
" let timeStamp = formatTime defaultTimeLocale \"%H:%M:%S\" t",
" putStrLn $ timeStamp ++ \" | \" ++ s"] ++
includeLines [
"getDepPaths :: [Flag] -> [String]",
"getDepPaths [] = []",
"getDepPaths ((Dep s):fs) = s:(getDepPaths fs)",
"getDepPaths (_:fs) = getDepPaths fs"
] ++ [
"main :: IO ()",
"main = do",
" (flags, args) <- getArgs >>= handleArgs",
" if elem Ext flags then putStrLn \"Files in the form name." ++ ext ++ " are compiled to name.c\"",
" else if elem Info flags then putStrLn \"This compiler was automatically generated by a compiler generator written by Samuel Williams\\nhttps://github.com/samuelWilliams99/\"",
" else if length args /= 1 then usageError []",
" else runCompiler (head args) (getOutputPath flags) (elem Verbose flags)" ++ if hasIncludes then " (getDepPaths flags)" else "",
"resultToIO :: Result a -> IO a",
"resultToIO (Error e) = die e",
"resultToIO (Result a) = return a"] ++
if hasIncludes then hasIncludesCode ext else noIncludesCode ext
where
includeLines ls = if hasIncludes then ls else []
hasIncludesCode :: String -> [String]
hasIncludesCode ext = [
"volatileStateFilterNames :: (String -> Bool) -> VolatileState -> VolatileState",
"volatileStateFilterNames f vs = vs { _vars = filterWithKey (\\k _ -> f k) (_vars vs),",
" _staticFuncs = filterWithKey (\\(k, _) _ -> f k) (_staticFuncs vs) }",
"getIncludeMap :: IncludeMapType -> (VolatileState -> VolatileState)",
"getIncludeMap IncludeMapEverything vs = vs",
"getIncludeMap (IncludeMapWhitelist ks) vs = volatileStateFilterNames (\\k -> elem k ks) vs",
"getIncludeMap (IncludeMapBlacklist ks) vs = volatileStateFilterNames (\\k -> not $ elem k ks) vs",
"getIncludeMap (IncludeMapRename ns) vs =",
" vs { _vars = foldrWithKey (\\k v m ->",
" if member k nm then Map.insert (nm ! k) v $ delete k m else m",
" ) vars vars",
" , _staticFuncs = foldrWithKey (\\(k, as) v m ->",
" if member k nm then Map.insert (nm ! k, as) v $ delete (k, as) m else m",
" ) funcs funcs",
" }",
" where",
" nm = fromList ns",
" vars = _vars vs",
" funcs = _staticFuncs vs",
"computeIncludeMap :: IncludeMap -> (VolatileState -> VolatileState)",
"computeIncludeMap (IncludeMap t Nothing) = getIncludeMap t",
"computeIncludeMap (IncludeMap t (Just next)) = computeIncludeMap next . getIncludeMap t",
"getRealPath :: [String] -> String -> IO String",
"getRealPath deps path = do",
" paths' <- mapM (canonicalizePath . (</> (path -<.> " ++ show ext ++ "))) (\"\":deps)",
" let paths = nub paths'",
" exists <- mapM doesFileExist paths",
" let validPaths = fmap snd $ List.filter fst $ zip exists paths",
" if validPaths == [] then",
" die $ \"Could not find file \\\"\" ++ path ++ \"\\\"\"",
" else if length validPaths == 1 then do",
" return $ head validPaths",
" else",
" die $ \"Found multiple of same file:\\n\" ++ intercalate \"\\n\" validPaths",
"runCompiler :: String -> Maybe String -> Bool -> [String] -> IO ()",
"runCompiler inp mOutp verbose deps",
" | takeExtension inp /= \"." ++ ext ++ "\" = die \"Invalid file extension, must be ." ++ ext ++ "\"",
" | otherwise = do",
" let outp = fromMaybe (replaceExtension inp \"c\") mOutp",
" code <- compile verbose deps inp",
" logV verbose $ \"Writing code to \" ++ outp",
" writeFile outp code",
"hasCycles :: HashMap String [String] -> Maybe [String]",
"hasCycles m = asum $ fmap (aux []) (keys m)",
" where",
" aux visited k = if elem k visited then Just (k:visited) else asum $ fmap (aux (k:visited)) (m ! k)",
"isIncludeReady :: [String] -> [String] -> Bool",
"isIncludeReady inp outp = all (\\x -> elem x outp) inp",
"getIncludeOrder :: HashMap String [String] -> Result [String]",
"getIncludeOrder m = case hasCycles m of",
" Just xs -> Error $ \"Cyclic includes found: \\n\" ++ indent (intercalate \" ->\\n\" xs)",
" Nothing ->",
" let ks = sortBy (comparing (length . (m !))) (keys m)",
" in Result $ reverse $ aux [] ks []",
" where",
" aux ks' (k:ks) out =",
" if isIncludeReady (m ! k) out then",
" aux [] (ks' ++ ks) (k:out)",
" else",
" aux (ks' ++ [k]) ks out",
" aux _ [] out = out",
"showPath :: String -> Result a -> Result a",
"showPath _ (Result a) = Result a",
"showPath path (Error e) = Error $ path ++ \" =>\\n\" ++ indent e",
"getParseTrees :: Bool -> [String] -> String -> [String] -> IO (HashMap String (ASTCommand, [(String, VolatileState -> VolatileState)]))",
"getParseTrees verbose deps path visited = do",
" content <- readFile path",
" logV verbose $ \"Parsing \" ++ path",
" (syntax, includes) <- resultToIO $ showPath path $ runParser content",
" realIncludes <- mapM (\\(i, im) -> fmap (\\i' -> (i', computeIncludeMap im)) $ getRealPath deps i) includes",
" let newIncludes = List.filter (\\include -> not $ elem include (path:visited)) $ fmap fst realIncludes",
" ms <- mapM (\\p -> getParseTrees verbose deps p ([path] ++ newIncludes ++ visited)) newIncludes",
" return $ Map.insert path (syntax, realIncludes) $ unions ms",
"removeGlobals :: HashMap a [Var b] -> HashMap a [Var b]",
"removeGlobals m = fmap (pure . setScope . head) $ Map.filter ((>0) . length) $ fmap (List.filter ((/=(-1)) . _varScopeLevel)) m",
" where setScope v = v { _varScopeLevel = -1 }",
"cleanVolitileState :: VolatileState -> VolatileState",
"cleanVolitileState vs = vs { _vars = removeGlobals $ _vars vs, _staticFuncs = removeGlobals $ _staticFuncs vs }",
"getSemantics :: [(String, ASTCommand, [(String, VolatileState -> VolatileState)])] -> Bool -> Int -> VolatileState -> HashMap String VolatileState -> PersistentState -> IO String",
"getSemantics [] _ _ _ _ _ = return \"\"",
"getSemantics ((p, cmd, includes):fs) verbose i def sm pState = do",
" let vStates = def:(fmap (\\(path, f) -> f (sm ! path)) includes)",
" let vState = mconcat vStates",
" logV verbose $ \"[\" ++ show i ++ \" of \" ++ show (i + length fs) ++ \"] Compiling \" ++ p",
" (c, SemanticsState pStateOut vStateOut _) <- resultToIO $ showPath p $ runSemantics (SemanticsState pState vState $ parseState \"\") cmd",
" let vStateOut' = cleanVolitileState vStateOut",
" c' <- getSemantics fs verbose (i+1) def (Map.insert p vStateOut' sm) pStateOut",
" return $ c ++ \"\\n\\n\" ++ c'",
"compile :: Bool -> [String] -> String -> IO String",
"compile verbose deps path = do",
" realPath <- getRealPath deps path",
" m <- getParseTrees verbose deps realPath []",
" logV verbose $ \"Finished parsing, found \" ++ show (size m) ++ \" files\"",
" includeOrder <- resultToIO $ getIncludeOrder $ fmap (fmap fst . snd) m",
" logV verbose \"Resolved dependencies\"",
" let includeOrder' = [(p, cmd, is) | p <- includeOrder, let (cmd, is) = m ! p]",
" (SemanticsState pState vState _) <- resultToIO rDefaultState",
" code <- getSemantics includeOrder' verbose 1 vState empty pState",
" logV verbose $ \"Finished compiling \" ++ show (size m) ++ \" files\"",
" let wrappedCode = \"int main() {\\n\" ++ indent code ++ \"\\n return 0;\\n}\"",
" return $ _outPreCode ++ wrappedCode"
]
noIncludesCode :: String -> [String]
noIncludesCode ext = [
"runCompiler :: String -> Maybe String -> Bool -> IO ()",
"runCompiler inp mOutp verbose",
" | takeExtension inp /= \"." ++ ext ++ "\" = die \"Invalid file extension, must be ." ++ ext ++ "\"",
" | otherwise = do",
" let outp = fromMaybe (replaceExtension inp \"c\") mOutp",
" exists <- doesFileExist inp",
" if not exists then",
" die $ \"Could not find file \\\"\" ++ inp ++ \"\\\"\"",
" else do",
" content <- readFile inp",
" code <- compile verbose content",
" logV verbose $ \"Writing code to \" ++ outp",
" writeFile outp code",
"compile :: Bool -> String -> IO String",
"compile verbose s = do",
" logV verbose \"Parsing file\"",
" syntax <- resultToIO $ runParser s",
" defaultState <- resultToIO $ rDefaultState",
" logV verbose \"Compiling file\"",
" (code, _) <- resultToIO $ runSemantics defaultState syntax",
" let wrappedCode = \"int main() {\\n\" ++ indent code ++ \"\\n return 0;\\n}\"",
" return $ _outPreCode ++ wrappedCode"
]