blob: a118103f67403f3a4a12e61c0c610660b9886dce (
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
|
module Fun.Compiler where
import Control.Exception
import Fun.Grammar
import Fun.Parser
import Fun.Syntax
import Fun.Tree
import System.Exit
import System.IO
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 Tree
parse s = case tree 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) ""
-- TODO: Find higher-order infix
f <~ e = case e of
Left e -> Left e
Right e -> f e
compile :: String -> IO ()
compile path = do
file <- try $ readFile path
case file of
Left exception -> print (exception :: IOError)
Right file -> case check <~ parse file of
Left err -> do
hPutStrLn stderr err
exitWith (ExitFailure 1)
Right block -> putStrLn . show $ block
|
