diff options
| -rw-r--r-- | src/Language/Fiddle/Compiler.hs | 59 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Expansion.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/ImportResolution.hs | 41 | ||||
| -rw-r--r-- | src/Main.hs | 89 |
5 files changed, 109 insertions, 84 deletions
diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs index 0fe277f..5be6355 100644 --- a/src/Language/Fiddle/Compiler.hs +++ b/src/Language/Fiddle/Compiler.hs @@ -1,18 +1,5 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- Compilation monad. Has diagnostics. Optionally produces a value. --- newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a)) --- Runs a sub-compilation routine with the given state, but discards the --- resulting state in favor of the original state. --- mapMaybeT (mapRWS (\(a, _, w) -> (a, s', w))) mtrws --- Saves the state, runs the routine, then restores the state. --- Runs a compilation routine. It produces diagnostics and maybe a result. --- Generally if the diagnostics contain an error, the result will be Nothing, --- but if only Warnings are generated, then Just something will be returned. --- --- Note that there is no actual type-level mechanism restricting this function --- from returning something even if the diagnostics contain errors, but it --- generally wouldn't make much sense for this to be the case. {-# LANGUAGE RankNTypes #-} module Language.Fiddle.Compiler where @@ -26,6 +13,7 @@ import Control.Monad.Writer import Data.Default import Language.Fiddle.Ast import Language.Fiddle.Types +import Options.Applicative import System.IO (hPutStrLn, stderr) import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName) @@ -114,13 +102,15 @@ fromMayberOrFail _ _ (Just a) = return a -- 'FiddleUnit' from the current stage to the next. data CompilationPhase stageFrom stageTo where CompilationPhase :: - forall privateState stageFrom stageTo. + forall privateFlags privateState stageFrom stageTo. (CompilationStage stageFrom) => - { -- | 'ioAction' is an IO operation that runs after the ast is parsed. It + { optionsParser :: Parser privateFlags, + -- | 'ioAction' is an IO operation that runs after the ast is parsed. It -- takes the parsed 'FiddleUnit' and performs some side effect -- returning a private state that is passed to 'nextStage'. This is the -- only time a side effect may be performed. ioAction :: + privateFlags -> FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) -> IO privateState, -- | 'nextStage' is the function that transforms a 'FiddleUnit' from @@ -128,6 +118,7 @@ data CompilationPhase stageFrom stageTo where -- uses the private state obtained from 'ioAction' and outputs a -- potentially updated 'FiddleUnit' in the compilation pipeline. nextStage :: + privateFlags -> privateState -> FiddleUnit stageFrom @@ -150,13 +141,14 @@ thenPhase :: CompilationPhase stage2 stage3 -> CompilationPhase stage1 stage3 thenPhase - (CompilationPhase ioAction1 compile1) - (CompilationPhase ioAction2 compile2) = + (CompilationPhase optParse1 ioAction1 compile1) + (CompilationPhase optParse2 ioAction2 compile2) = CompilationPhase - (\unit -> (,) <$> ioAction1 unit <*> ioAction2 unit) - ( \(s1, s2) firstStage -> do - secondStage <- compile1 s1 firstStage - compile2 s2 secondStage + ((,) <$> optParse1 <*> optParse2) + (\(f1, f2) unit -> (,) <$> ioAction1 f1 unit <*> ioAction2 f2 unit) + ( \(f1, f2) (s1, s2) firstStage -> do + secondStage <- compile1 f1 s1 firstStage + compile2 f2 s2 secondStage ) -- | Infix operator for 'thenPhase' to chain compilation phases. @@ -167,15 +159,22 @@ thenPhase -- from the 'Parsed' phase. It performs the IO action of the first phase and -- then invokes the compilation function for the remaining stages. It returns -- a tuple containing diagnostics and an optional final 'FiddleUnit'. -execCompilationPipeline :: +execCompilationPipelineWithCmdline :: CompilationPhase Parsed s' -> - FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) -> - IO - ( [Diagnostic], - Maybe - ( FiddleUnit s' (StageFunctor s') (StageAnnotation s') + Parser + ( FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) -> + IO + ( [Diagnostic], + Maybe + ( FiddleUnit s' (StageFunctor s') (StageAnnotation s') + ) ) ) -execCompilationPipeline (CompilationPhase ioAction rest) ast = do - s <- ioAction ast - return $ compile_ $ rest s ast +execCompilationPipelineWithCmdline + (CompilationPhase flagsParser ioAction rest) = do + fmap + ( \opts ast -> do + s <- ioAction opts ast + return $ compile_ $ rest opts s ast + ) + flagsParser diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index 4c708f7..5c7b399 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -54,7 +54,7 @@ type SizeBytes = Word32 consistencyCheckPhase :: CompilationPhase Expanded Checked consistencyCheckPhase = - CompilationPhase (const $ return ()) (\() -> checkConsistency) + CompilationPhase (pure ()) (\_ _ -> return ()) (\_ _ -> checkConsistency) checkConsistency :: FiddleUnit Expanded I Annot -> diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs index 77ccf6c..7201686 100644 --- a/src/Language/Fiddle/Compiler/Expansion.hs +++ b/src/Language/Fiddle/Compiler/Expansion.hs @@ -39,7 +39,7 @@ expandAst :: FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Expanded expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty) expansionPhase :: CompilationPhase CurrentStage Expanded -expansionPhase = CompilationPhase (const $ return ()) (\() -> expandAst) +expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ()) (\_ _ -> expandAst) -- Shorthand for Identity type I = Identity diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs index b4c5293..90a11d5 100644 --- a/src/Language/Fiddle/Compiler/ImportResolution.hs +++ b/src/Language/Fiddle/Compiler/ImportResolution.hs @@ -1,7 +1,6 @@ module Language.Fiddle.Compiler.ImportResolution ( resolveImports, getImportResolutionState, - ImportResolutionOptions (..), importResolutionPhase, ) where @@ -18,8 +17,30 @@ import Language.Fiddle.Compiler import Language.Fiddle.Compiler.Expansion import Language.Fiddle.Internal.UnitInterface import Language.Fiddle.Types +import Options.Applicative import Text.Printf (printf) +newtype Flags = Flags + { importDirectories :: [FilePath] + } + +parseFlags :: Parser Flags +parseFlags = + Flags + <$> many + ( strOption + ( long "import" + <> short 'I' + <> metavar "DIRECTORY" + <> help "Directory to add to the import search path" + ) + ) + +importResolutionPhase :: + CompilationPhase CurrentStage ImportsResolved +importResolutionPhase = + CompilationPhase parseFlags getImportResolutionState resolveImports + type GlobalState = () type LocalState = ResolvedImports @@ -46,19 +67,12 @@ instance CompilationStage CurrentStage where type StageFunctor CurrentStage = Identity type StageAnnotation CurrentStage = Annot -importResolutionPhase :: - ImportResolutionOptions -> - CompilationPhase CurrentStage ImportsResolved -importResolutionPhase opts = - CompilationPhase - (getImportResolutionState opts) - resolveImports - resolveImports :: + Flags -> ResolvedImports -> FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit ImportsResolved I Annot) -resolveImports = advanceStage +resolveImports _ = advanceStage deriving instance AdvanceStage CurrentStage ObjTypeBody @@ -111,13 +125,8 @@ instance AdvanceStage CurrentStage ImportStatement where return $ ImportStatement path list v a -newtype ImportResolutionOptions - = ImportResolutionOptions - { searchPath :: [FilePath] - } - getImportResolutionState :: - ImportResolutionOptions -> + Flags -> FiddleUnit CurrentStage Identity Annot -> IO ResolvedImports getImportResolutionState _ _ = return (ResolvedImports mempty) diff --git a/src/Main.hs b/src/Main.hs index f643320..352a8cc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,51 +19,68 @@ import Language.Fiddle.Compiler.Stage0 import Language.Fiddle.GenericTree (GenericSyntaxTree (..), ToGenericSyntaxTree (toGenericSyntaxTree), alterGenericSyntaxTree) import qualified Language.Fiddle.Parser import qualified Language.Fiddle.Tokenizer +import Options.Applicative import qualified System.Environment as System import System.Exit (exitWith) -phases res = - importResolutionPhase res >>> expansionPhase >>> consistencyCheckPhase +compilationPipeline = + importResolutionPhase >>> expansionPhase >>> consistencyCheckPhase + +newtype GlobalFlags + = GlobalFlags + { flagsInputFile :: String + } + +parseGlobalFlags :: Parser GlobalFlags +parseGlobalFlags = + GlobalFlags + <$> argument str (metavar "INPUT" <> help "Input file") main :: IO () main = do - argv <- System.getArgs - let opts = ImportResolutionOptions ["."] + (globalFlags, compilationPipelineAction) <- + execParser $ + info + ( ( (,) + <$> parseGlobalFlags + <*> execCompilationPipelineWithCmdline compilationPipeline + ) + <**> helper + ) + ( fullDesc + <> progDesc "Compile Fiddle Files" + <> header "fiddlec - A compiler for fiddle files" + ) - case argv of - [filePath] -> do - text <- Data.Text.IO.readFile filePath - let maybeParsedAst = compile_ $ toStage0 filePath text >>= toStage1 + let filePath = flagsInputFile globalFlags + text <- Data.Text.IO.readFile filePath - case maybeParsedAst of - (priorDiags, Just ast) -> do - ((priorDiags ++) -> diags, ma) <- - execCompilationPipeline (phases opts) ast - 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) + let maybeParsedAst = compile_ $ toStage0 filePath text >>= toStage1 + case maybeParsedAst of + (priorDiags, Just ast) -> do + ((priorDiags ++) -> diags, ma) <- compilationPipelineAction ast + 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 - (diags, _) -> do - putStrLn "\x1b[1;31mParsing Failed\x1b[0m" - forM_ diags printDiagnostic - exitWith (ExitFailure 1) - _ -> do - putStrLn "Wrong Args" - exitWith (ExitFailure 2) + forM_ diags printDiagnostic + exitWith ec + (diags, _) -> do + putStrLn "\x1b[1;31mParsing Failed\x1b[0m" + forM_ diags printDiagnostic + exitWith (ExitFailure 1) cleanupIdentifiers :: GenericSyntaxTree Identity a -> Maybe (GenericSyntaxTree Identity a) cleanupIdentifiers (SyntaxTreeObject _ _ _ tr) |