blob: 563f03956897d15a8bc2ddad827b692d7eb2d773 (
plain) (
blame)
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
|
{-# LANGUAGE ScopedTypeVariables #-}
module Fun.Compiler where
import Control.Exception
import Fun.Generator
import Fun.Grammar
import Fun.Parser
import Fun.Syntax
import Fun.Tree
import System.Exit
import System.IO
import Text.Read
traceBranch :: Int -> Trace -> String
traceBranch c (StringTrace t) = "\n" ++ (replicate c ' ') ++ t
traceBranch c (OrTrace t1 t2) =
"\n"
++ (replicate c ' ')
++ "<either>"
++ (traceTree (c + 2) t1)
++ (traceTree (c + 2) t2)
traceTree :: Int -> [Trace] -> String -- TODO: Indent/arrow first map
traceTree c ts = foldr join "" $ map (traceBranch c) ts
where join = (\a b -> a ++ if b == "" then b else " " ++ b)
genTrace :: [Trace] -> String
genTrace ts = "Trace of expectance:\n" ++ traceTree 0 ts
parse :: String -> Either String Program
parse s = case program s of
Left a -> Left $ "Parse error!\n" ++ case a of
State [] Nothing -> "No context available"
State t Nothing -> genTrace t
State [] (Just str) -> "Around here:\n" ++ str
State t (Just str) -> genTrace t ++ "\nAround here:\n" ++ str
Right (a, b) -> Right a
check :: Tree -> Either String Tree
check t = case checkTree t of
Left a -> Left $ "Syntax error!\n" ++ (join a)
Right a -> Right a
where
join = foldr (\(SyntaxError a) b -> a ++ if b == "" then b else "\n" ++ b) ""
generate :: Tree -> Either String String
generate t = case generateAsm t of
Left (GenerateError a) -> Left $ "Error while generating ASM!\n" ++ a
Right a -> Right a
failExit :: String -> IO ()
failExit err = do
hPutStrLn stderr err
exitWith (ExitFailure 1)
compile :: [String] -> IO ()
compile paths = do
files <- sequence
$ map (\p -> try $ readFile p :: IO (Either IOError String)) paths
case sequence files of -- TODO: Improve this left/right chain
Left exception -> print (exception :: IOError)
Right files -> case sequence $ map parse files of
Left err -> failExit err
Right ps -> case check (Tree ps) >>= generate of
Left err -> failExit err
Right gen -> putStrLn gen
|
