blob: 6fba502093933a5c3a3e34c4fdcb1282919046c5 (
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
|
module Main where
import Control.Monad (forM_)
import Control.Monad.Identity (Identity)
import Control.Monad.Writer
import Data.Aeson (Value (Null), encode)
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Data (cast)
import qualified Data.Text as Text
import qualified Data.Text.IO
import Data.Typeable
import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
import Language.Fiddle.Ast
import Language.Fiddle.Compiler (coloredFormat, compile_, printDiagnostic)
import Language.Fiddle.Compiler.Stage0
import Language.Fiddle.Compiler.Stage1
import Language.Fiddle.Compiler.Stage2
import Language.Fiddle.GenericTree (GenericSyntaxTree (..), ToGenericSyntaxTree (toGenericSyntaxTree), alterGenericSyntaxTree)
import qualified Language.Fiddle.Parser
import qualified Language.Fiddle.Tokenizer
import qualified System.Environment as System
import System.Exit (exitWith)
main :: IO ()
main = do
argv <- System.getArgs
case argv of
[filePath] -> do
text <- Data.Text.IO.readFile filePath
let (diags, ma) = compile_ $ toStage3 =<< toStage2 =<< toStage1 =<< toStage0 filePath text
ec <-
case ma of
Just ast -> do
putStrLn $
BL.unpack $
encode $
alterGenericSyntaxTree cleanupIdentifiers $
toGenericSyntaxTree $
fmap
(const (Nothing :: Maybe Value))
ast
return ExitSuccess
Nothing -> do
putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
return (ExitFailure 1)
forM_ diags printDiagnostic
exitWith ec
_ -> do
putStrLn "Wrong Args"
exitWith (ExitFailure 2)
cleanupIdentifiers :: GenericSyntaxTree Identity a -> Maybe (GenericSyntaxTree Identity a)
cleanupIdentifiers (SyntaxTreeObject _ _ _ tr)
| (Just (Identifier n _)) <- castT tr =
Just $ SyntaxTreeValue (Text.unpack n)
where
castT ::
(Typeable t, Typeable f, Typeable a, Typeable t') =>
t f a ->
Maybe (t' f a)
castT = cast
cleanupIdentifiers _ = Nothing
|
