summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs31
1 files changed, 27 insertions, 4 deletions
diff --git a/src/Main.hs b/src/Main.hs
index f92d6c6..6fba502 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,17 +1,21 @@
module Main where
import Control.Monad (forM_)
+import Control.Monad.Identity (Identity)
import Control.Monad.Writer
-import Data.Aeson (encode)
+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 (ToGenericSyntaxTree (toGenericSyntaxTree))
+import Language.Fiddle.GenericTree (GenericSyntaxTree (..), ToGenericSyntaxTree (toGenericSyntaxTree), alterGenericSyntaxTree)
import qualified Language.Fiddle.Parser
import qualified Language.Fiddle.Tokenizer
import qualified System.Environment as System
@@ -25,10 +29,17 @@ main = do
[filePath] -> do
text <- Data.Text.IO.readFile filePath
let (diags, ma) = compile_ $ toStage3 =<< toStage2 =<< toStage1 =<< toStage0 filePath text
- ec <-
+ ec <-
case ma of
Just ast -> do
- putStrLn $ BL.unpack $ encode $ toGenericSyntaxTree ast
+ putStrLn $
+ BL.unpack $
+ encode $
+ alterGenericSyntaxTree cleanupIdentifiers $
+ toGenericSyntaxTree $
+ fmap
+ (const (Nothing :: Maybe Value))
+ ast
return ExitSuccess
Nothing -> do
putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
@@ -39,3 +50,15 @@ main = do
_ -> 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