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.Build.Interface.Store (Store)
import DDC.Base.Pretty
import qualified DDC.Build.Transform.Resolve as B
import qualified DDC.Source.Tetra.Convert 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.Pretty ()
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.Fragment 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 qualified DDC.Data.Token as Token
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
-> !Sink
-> !Sink
-> !Store
-> ![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
sinkDesugared sinkCore sinkPreCheck sinkCheckerTrace
store pipes
->
let
goParse
= do
let tokens = SE.lexModuleString srcName srcLine str
pipeSink (unlines $ map (show . Token.tokenTok) $ tokens)
sinkTokens
case BP.runTokenParser C.describeTok srcName
(SE.pModule SE.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
pipeSink (renderIndent $ ppr mm_expand) sinkDesugared
let sp = SP.SourcePos "<top level>" 1 1
case SE.coreOfSourceModule sp mm_expand of
Left err
-> return [ErrorLoad err]
Right mm_core
-> do
pipeSink (renderIndent $ ppr mm_core) sinkCore
result <- B.resolveNamesInModule
CE.primKindEnv CE.primTypeEnv
store mm_core
case result of
Left err -> return [ErrorLoad err]
Right mm_resolved -> goSpread mm_resolved
goSpread mm
= do
let mm_spread = C.spreadX CE.primKindEnv CE.primTypeEnv mm
pipeSink (renderIndent $ ppr mm_spread) sinkPreCheck
let fragment_implicit
= flip C.mapProfileOfFragment CE.fragment
$ C.mapFeaturesOfProfile
$ ( C.setFeature C.ImplicitRun True
. C.setFeature C.ImplicitBox True)
pipeCore mm_spread
$ PipeCoreCheck fragment_implicit C.Synth sinkCheckerTrace pipes
in goParse
where sinkCheckTrace mct sink
= case mct of
Nothing -> return []
Just (C.CheckTrace doc) -> pipeSink (renderIndent doc) sink