-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathHusk.hs
158 lines (146 loc) · 7.47 KB
/
Husk.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
{-# LANGUAGE QuasiQuotes #-}
-- Main program
import Debug
import Expr
import Infer
import Parser
import InputParser
import Codepage
import Codegen
import FileQuoter
import System.Environment (getArgs)
import System.Console.GetOpt
import System.Process
import System.IO
import qualified Data.ByteString as B
import Data.List (find, intercalate, nub)
import Data.Set (toAscList)
-- Wrapper for expression parser
parseProg :: Bool -> String -> [Type] -> Either String [[(Int, CType, Exp (Lit CType))]]
parseProg constrainRes prog types = inferType constrainRes (foldr typeConstr resType types) <$> parseExpr prog
where typeConstr typ1 (Scheme vars (CType cons typ2)) =
Scheme (nub $ vars ++ toAscList (freeVars typ1)) $
CType cons $
TFun typ1 typ2
cons = if constrainRes then [Concrete $ TVar "x"] else []
resType = Scheme ["x"] $ CType cons $ TVar "x"
-- Input format flags
data Format = Bytes
| Unicode
| Verbose
deriving (Eq, Show)
-- Command line option flags
data Flag = InferType
| InferInputType
| InFile
| OutFile String
| Format Format
| Translate Format
deriving (Eq, Show)
isOutFile :: Flag -> Bool
isOutFile (OutFile _) = True
isOutFile _ = False
isFormat :: Flag -> Bool
isFormat (Format _) = True
isFormat _ = False
isTranslate :: Flag -> Bool
isTranslate (Translate _) = True
isTranslate _ = False
-- Command line options
consoleOpts :: [OptDescr Flag]
consoleOpts = [Option ['b'] ["bytes"] (NoArg $ Format Bytes) "take input as bytes",
Option ['u'] ["unicode"] (NoArg $ Format Unicode) "take input as Unicode characters",
Option ['v'] ["verbose"] (NoArg $ Format Verbose) "take input as verbose ASCII",
Option ['i'] ["infer"] (NoArg InferType) "only infer type(s) of given program",
Option ['I'] ["infer2"] (NoArg InferInputType) "infer type(s) of given program, taking input type(s) into account",
Option ['f'] ["file"] (NoArg InFile) "read program from file",
Option ['o'] ["out"] (ReqArg OutFile "FILE") "produce Haskell file of given name",
Option ['t'] ["translate"] (ReqArg (Translate . parseFormat) "FORMAT") "translate source to specified format (b/u/v)"
]
where parseFormat "b" = Bytes
parseFormat "u" = Unicode
parseFormat "v" = Verbose
parseFormat _ = error "Bad format specifier"
-- Imports needed for transpiled file
fileImports :: String
fileImports = unlines $ map ("import "++) $ ["Defs", "IntSeq", "System.Environment (getArgs)"]
-- Produce Haskell file from list of type-inferred lines
produceFile :: [(Int, CType, Exp (Lit CType))] -> String
produceFile exprs =
fileImports ++
progLines ++
"main :: IO ()\n" ++
"main = do{[" ++ intercalate "," argList ++ "] <- getArgs; " ++
"let{res = line0 " ++ concatMap (\a -> "(read " ++ a ++ ")") argList ++ "}; " ++
"putStr (toString res)}"
where progLines = concat [ label ++ " :: " ++ cTypeToHaskell typ ++ "\n" ++
label ++ " = " ++ expToHaskell expr ++ "\n"
| (i, typ, expr) <- exprs,
let label = "line" ++ show i]
(_, CType _ mainTyp, _) = exprs !! 0
argList = ["arg" ++ show i | i <- [1..numArgs mainTyp]]
numArgs (TFun _ t) = 1 + numArgs t
numArgs _ = 0
main = do
args <- getArgs
let parsedArgs = getOpt RequireOrder consoleOpts args
case parsedArgs of
(opts, (progOrFile : progArgs), []) -> traceShow' 1 opts $ do
errOrProg <- if InFile `elem` opts
then case find isFormat opts of
Just (Format Bytes) -> Right . getCommands . B.unpack <$> B.readFile progOrFile
Just (Format f) -> do
handle <- openFile progOrFile ReadMode
hSetEncoding handle utf8
contents <- hGetContents handle
return $ case f of
Verbose -> parseAliases contents
_ -> Right contents
_ -> return $ Left "Must supply input format"
else return $ case find isFormat opts of
Just (Format Bytes) -> Left "Byte format not supported for console input"
Just (Format Verbose) -> parseAliases progOrFile
Just (Format Unicode) -> Right progOrFile
_ -> Left "Must supply input format"
case errOrProg of
Left err -> putStrLn err
Right prog ->
let progInputs :: Either String (Maybe [(String,Type)])
progInputs = fmap sequence $ sequence $ zipWith parseInput [1..] progArgs
in case progInputs of
Left err -> putStrLn err
Right Nothing -> putStrLn "Could not infer valid type(s) for input(s)"
Right (Just typedArgs) ->
if any (`elem` opts) [InferType, InferInputType]
then let constrainType = InferInputType `elem` opts
inputs = if InferInputType `elem` opts then map snd typedArgs else []
in case parseProg constrainType prog inputs of
Left err -> putStrLn err
Right typings -> flip mapM_ typings $
\exprs -> do
putStrLn "%%%%"
flip mapM_ exprs $
\(i, typ, expr) -> do
putStrLn $ "line" ++ show i ++ " = " ++ show expr ++ " :: " ++ show typ
else case find isTranslate opts of
Just (Translate Verbose) -> putStrLn $ toAliases prog
Just (Translate Unicode) -> putStrLn prog
Just (Translate Bytes) ->
let bytes = B.pack $ getBytes prog
in case find isOutFile opts of
Just (OutFile filename) -> B.writeFile filename bytes
_ -> B.putStr bytes
_ -> do
let outfile = case (find isOutFile opts, InFile `elem` opts) of
(Just (OutFile s), _) -> s
(Nothing, True) -> progOrFile ++ ".hs"
(Nothing, False) -> ".out.hs"
case parseProg True prog (map snd typedArgs) of
Left err -> putStrLn err
Right [] -> putStrLn "Could not infer valid type for program"
Right (lineExprs : _) -> do writeFile outfile $ produceFile lineExprs
(_, Just hout, _, _) <- createProcess (proc "runhaskell" (outfile : map fst typedArgs)){ std_out = CreatePipe }
result <- hGetContents hout
hSetBuffering stdout NoBuffering
putStr result
(_, _, errs) -> putStrLn $ concat errs ++ usageInfo "Usage: main [OPTION...] [FILE|EXPR] [INPUT...]" consoleOpts