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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
{-# 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
import Control.Monad (when)
import Control.Monad.Identity (Identity)
import Control.Monad.RWS (RWS, RWST, evalRWS, mapRWS, runRWS)
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Control.Monad.Writer
import Data.Default
import Language.Fiddle.Ast
import Language.Fiddle.Types
import System.IO (hPutStrLn, stderr)
import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName)
data Level = Error | Warning | Info
data Diagnostic = Diagnostic Level String SourceSpan
newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a)
deriving newtype (Functor, Applicative, Monad)
compilationFailure :: Compile s a
compilationFailure = Compile $ MaybeT (return Nothing)
instance MonadWriter [Diagnostic] (Compile s) where
tell = Compile . tell
listen (Compile fn) = Compile $ listen fn
pass (Compile fn) = Compile $ pass fn
instance MonadState s (Compile s) where
get = Compile get
put s = Compile $ put s
state fn = Compile $ state fn
subCompile :: s' -> Compile s' a -> Compile s (s', a)
subCompile s' (Compile mtrws) = Compile $ do
let (a, s, w) = runRWS (runMaybeT mtrws) () s'
tell w
MaybeT $ return $ fmap (s,) a
pushState :: Compile s a -> Compile s a
pushState cp = do
s <- get
snd <$> subCompile s cp
compile :: Compile s a -> s -> ([Diagnostic], Maybe a)
compile (Compile fn) initState = do
let (a, _, w) = runRWS (runMaybeT fn) () initState in (w, a)
compile_ :: (Default s) => Compile s a -> ([Diagnostic], Maybe a)
compile_ c = compile c def
hoistMaybe :: Maybe a -> Compile s a
hoistMaybe = Compile . MaybeT . return
newtype DiagnosticFormat = DiagnosticFormat (Diagnostic -> String)
coloredFormat :: DiagnosticFormat
coloredFormat = DiagnosticFormat $ \(Diagnostic level message (SourceSpan pos1 pos2)) ->
execWriter $ do
case level of
Error -> tell "\x1b[01;31mError "
Warning -> tell "\x1b[01;33mWarn "
Info -> tell "\x1b[01;37mInfo "
tell "\x1b[0m"
tell (sourceName pos1)
tell "("
tellPos pos1
when (pos2 /= pos1) $ do
tell "-"
tellPos pos2
tell "): "
tell (unwords $ words message)
where
tellPos pos = do
tell (show $ sourceLine pos)
tell ":"
tell (show $ sourceColumn pos)
diagnosticToString :: DiagnosticFormat -> Diagnostic -> String
diagnosticToString (DiagnosticFormat f) = f
printDiagnostic :: Diagnostic -> IO ()
printDiagnostic d =
hPutStrLn stderr (diagnosticToString coloredFormat d)
fromMayberOrFail :: SourceSpan -> String -> Maybe a -> Compile s a
fromMayberOrFail sourceSpan err Nothing = do
tell [Diagnostic Error err sourceSpan]
compilationFailure
fromMayberOrFail _ _ (Just a) = return a
-- | 'CompilationPhase' represents a phase in the compilation process.
-- It consists of an IO action that performs necessary side effects or state
-- preparations before the next stage, and a function that transforms the
-- 'FiddleUnit' from the current stage to the next.
data CompilationPhase stageFrom stageTo where
CompilationPhase ::
forall privateState stageFrom stageTo.
(CompilationStage stageFrom) =>
{ -- | '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 ::
FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) ->
IO privateState,
-- | 'nextStage' is the function that transforms a 'FiddleUnit' from
-- the current stage ('stageFrom') to the next stage ('stageTo'). It
-- uses the private state obtained from 'ioAction' and outputs a
-- potentially updated 'FiddleUnit' in the compilation pipeline.
nextStage ::
privateState ->
FiddleUnit
stageFrom
(StageFunctor stageFrom)
(StageAnnotation stageFrom) ->
Compile
()
( FiddleUnit
stageTo
(StageFunctor stageTo)
(StageAnnotation stageTo)
)
} ->
CompilationPhase stageFrom stageTo
-- | 'thenPhase' composes two 'CompilationPhase' stages into a single pipeline
-- phase. It combines their IO actions and applies each stage in sequence.
thenPhase ::
CompilationPhase stage1 stage2 ->
CompilationPhase stage2 stage3 ->
CompilationPhase stage1 stage3
thenPhase
(CompilationPhase ioAction1 compile1)
(CompilationPhase ioAction2 compile2) =
CompilationPhase
(\unit -> (,) <$> ioAction1 unit <*> ioAction2 unit)
( \(s1, s2) firstStage -> do
secondStage <- compile1 s1 firstStage
compile2 s2 secondStage
)
-- | Infix operator for 'thenPhase' to chain compilation phases.
(>>>) :: CompilationPhase stage1 stage2 -> CompilationPhase stage2 stage3 -> CompilationPhase stage1 stage3
(>>>) = thenPhase
-- | 'execCompilationPipeline' executes a full compilation pipeline starting
-- 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 ::
CompilationPhase Parsed s' ->
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
|
