module DDC.Build.Pipeline.Text
( PipeText (..)
, pipeText)
where
import DDC.Build.Pipeline.Error
import DDC.Build.Pipeline.Sink
import DDC.Build.Pipeline.Core
import DDC.Build.Language
import DDC.Base.Pretty
import qualified DDC.Source.Tetra.ToCore as SE
import qualified DDC.Source.Tetra.Transform.Defix as SE
import qualified DDC.Source.Tetra.Transform.Expand as SE
import qualified DDC.Source.Tetra.Parser as SE
import qualified DDC.Source.Tetra.Lexer as SE
import qualified DDC.Source.Tetra.Env as SE
import qualified DDC.Build.Language.Tetra as CE
import qualified DDC.Core.Tetra as CE
import qualified DDC.Core.Tetra.Env as CE
import qualified DDC.Core.Parser as C
import qualified DDC.Core.Transform.SpreadX as C
import qualified DDC.Core.Check as C
import qualified DDC.Core.Load as C
import qualified DDC.Core.Lexer as C
import qualified DDC.Base.Parser as BP
import qualified DDC.Data.SourcePos as SP
import Control.DeepSeq
data PipeText n (err :: * -> *) where
PipeTextOutput
:: !Sink
-> PipeText n err
PipeTextLoadCore
:: (Ord n, Show n, Pretty n, Pretty (err (C.AnTEC SP.SourcePos n)))
=> !(Fragment n err)
-> !(C.Mode n)
-> !Sink
-> ![PipeCore (C.AnTEC BP.SourcePos n) n]
-> PipeText n err
PipeTextLoadSourceTetra
:: !Sink
-> !Sink
-> !Sink
-> ![PipeCore (C.AnTEC BP.SourcePos CE.Name) CE.Name]
-> PipeText n err
pipeText
:: NFData n
=> String
-> Int
-> String
-> PipeText n err
-> IO [Error]
pipeText !srcName !srcLine !str !pp
= case pp of
PipeTextOutput !sink
->
pipeSink str sink
PipeTextLoadCore !fragment !mode !sink !pipes
->
let toks = fragmentLexModule fragment srcName srcLine str
in case C.loadModuleFromTokens fragment srcName mode toks of
(Left err, mct)
-> do sinkCheckTrace mct sink
return [ErrorLoad err]
(Right mm, mct)
-> do sinkCheckTrace mct sink
pipeCores mm pipes
PipeTextLoadSourceTetra
sinkTokens
sinkPreCheck
sinkCheckerTrace pipes
->
let goParse
= do
let tokens = SE.lexModuleString srcName srcLine str
pipeSink (unlines $ map show $ tokens) sinkTokens
let context = C.Context
{ C.contextTrackedEffects = True
, C.contextTrackedClosures = True
, C.contextFunctionalEffects = False
, C.contextFunctionalClosures = False }
case BP.runTokenParser C.describeTok srcName
(SE.pModule context) tokens of
Left err -> return [ErrorLoad err]
Right mm -> goDesugar mm
goDesugar mm
= case SE.defix SE.defaultFixTable mm of
Left err -> return [ErrorLoad err]
Right mm' -> goToCore mm'
goToCore mm
= do
let mm_expand = SE.expand SE.configDefault
SE.primKindEnv SE.primTypeEnv mm
let sp = SP.SourcePos "<top level>" 1 1
let mm_core = SE.toCoreModule sp mm_expand
let mm_spread = C.spreadX
CE.primKindEnv CE.primTypeEnv mm_core
pipeSink (renderIndent $ ppr mm_spread) sinkPreCheck
pipeCore mm_spread
$ PipeCoreCheck CE.fragment C.Synth sinkCheckerTrace pipes
in goParse
where sinkCheckTrace mct sink
= case mct of
Nothing -> return []
Just (C.CheckTrace doc) -> pipeSink (renderIndent doc) sink