{-# LANGUAGE FlexibleContexts #-}
module Require.Transform where
import Control.Monad.Except
import Control.Monad.Writer.Strict
import Data.DList (DList)
import qualified Data.Text as Text
import Relude
import Require.Error (Error(..))
import qualified Require.File as File
import qualified Require.Parser as Parser
import Require.Types
type TransformM =
StateT TransformState
(WriterT (DList Text)
(Either Error))
data TransformState = TransformState
{ tstLineTagOutput :: File.LineTag -> TransformM ()
, tstHostModule :: !(Maybe ModuleName)
, tstAutorequire :: !(AutorequireMode File.Input)
}
output :: Text -> TransformM ()
output = tell . pure
renderLineTag :: File.LineTag -> TransformM ()
renderLineTag (File.LineTag (File.Name fn) (File.LineNumber ln)) =
output $ "{-# LINE " <> show ln <> " \"" <> fn <> "\" #-}"
ignoreLineTag :: File.LineTag -> TransformM ()
ignoreLineTag = const (pure ())
transform :: AutorequireMode File.Input -> File.Input -> Either Error [Text]
transform autorequire input =
File.inputLines input
& traverse_ (process False)
& flip execStateT initialState
& chainedTo checkDidAutorequire
& execWriterT
& fmap toList
where
initialState = TransformState
{ tstLineTagOutput = renderLineTag
, tstHostModule = Nothing
, tstAutorequire = autorequire
}
unableToAutorequire resultState
| AutorequireEnabled _ <- autorequire
, AutorequireEnabled _ <- tstAutorequire resultState
= True
| otherwise
= False
checkDidAutorequire resultState
| unableToAutorequire resultState = throwError AutorequireImpossible
| otherwise = pure ()
process :: Bool -> (File.LineTag, Text) -> TransformM ()
process filterImports (tag, line) = do
let useTagPrep = do
tst <- get
tstLineTagOutput tst tag
put (tst { tstLineTagOutput = ignoreLineTag })
let lineWithAutorequire isDirective autoCondition = do
autoMode <- gets tstAutorequire
case autoMode of
AutorequireEnabled autoContent
| isDirective || autoCondition -> do
unless isDirective (useTagPrep >> output line)
processAutorequireContent autoContent
AutorequireOnDirective (Just autoContent)
| isDirective -> processAutorequireContent autoContent
AutorequireOnDirective Nothing
| isDirective -> throwError MissingOptionalRequiresFile
_ | isDirective -> pure ()
| otherwise -> useTagPrep >> output line
let hasWhere =
words line
& takeWhile (not . ("--" `Text.isPrefixOf`))
& elem "where"
case Parser.parseMaybe Parser.requireDirective line of
Nothing -> do
hasModule <- gets $ isJust . tstHostModule
lineWithAutorequire False $ hasModule && hasWhere
Just (ModuleDirective moduleName) -> do
modify $ \s -> s { tstHostModule = tstHostModule s <|> Just moduleName }
lineWithAutorequire False hasWhere
Just (RequireDirective ri) ->
renderImport filterImports tag ri
Just AutorequireDirective ->
lineWithAutorequire True False
processAutorequireContent :: File.Input -> TransformM ()
processAutorequireContent autorequireContent = do
modify $ \s -> s
{ tstLineTagOutput = renderLineTag
, tstAutorequire = AutorequireDisabled
}
traverse_ (process True) (File.inputLines autorequireContent)
modify $ \s -> s { tstLineTagOutput = renderLineTag }
renderImport :: Bool -> File.LineTag -> RequireInfo -> TransformM ()
renderImport filterImports line RequireInfo {..} = do
tst <- get
if filterImports && tstHostModule tst == Just riFullModuleName
then
put (tst { tstLineTagOutput = renderLineTag })
else do
tstLineTagOutput tst line
output typesImport
renderLineTag line
output qualifiedImport
put (tst { tstLineTagOutput = ignoreLineTag })
where
typesImport = unwords
[ "import"
, unModuleName riFullModuleName
, "(" <> riImportedTypes <> ")"
]
qualifiedImport = unwords
[ "import qualified"
, unModuleName riFullModuleName
, "as"
, riModuleAlias
]