{-# LANGUAGE FlexibleContexts #-}
module Require.Transform where
import qualified Data.Text as Text
import Relude
import qualified Require.File as File
import qualified Require.Parser as Parser
import Require.Types
type LineTagPrepend = File.LineTag -> Text -> Text
data TransformState = TransformState
{ tstLineTagPrepend :: !LineTagPrepend
, tstHostModule :: !(Maybe ModuleName)
, tstAutorequire :: !(AutorequireMode File.Input)
}
renderLineTag :: File.LineTag -> Text
renderLineTag (File.LineTag (File.Name fn) (File.LineNumber ln)) =
"{-# LINE " <> show ln <> " \"" <> fn <> "\" #-}\n"
prependLineTag :: LineTagPrepend
prependLineTag = (<>) . renderLineTag
ignoreLineTag :: LineTagPrepend
ignoreLineTag = const id
transform :: AutorequireMode File.Input -> File.Input -> Text
transform autorequire input =
File.inputLines input
& mapM (process (pure Nothing))
& flip evalState initialState
& mconcat
where
initialState = TransformState
{ tstLineTagPrepend = prependLineTag
, tstHostModule = Nothing
, tstAutorequire = autorequire
}
process
:: State TransformState (Maybe ModuleName)
-> (File.LineTag, Text)
-> State TransformState Text
process getHostModule (tag, line) = do
let useTagPrep text = do
prep <- gets tstLineTagPrepend
modify $ \s -> s { tstLineTagPrepend = ignoreLineTag }
pure $ prep tag text
let lineWithAutorequire isDirective autoCondition = do
autoMode <- gets tstAutorequire
case autoMode of
AutorequireEnabled autoContent
| isDirective || autoCondition -> do
line' <- if isDirective then pure "" else useTagPrep (line <> "\n")
auto <- processAutorequireContent autoContent
pure $ line' <> auto
AutorequireOnDirective (Just autoContent)
| isDirective -> do
processAutorequireContent autoContent
AutorequireOnDirective Nothing
| isDirective ->
error "Found an `autorequire` directive but no `Requires` file was found."
_ | isDirective -> pure ""
| otherwise -> useTagPrep $ line <> "\n"
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 getHostModule tag ri
Just AutorequireDirective ->
lineWithAutorequire True False
processAutorequireContent :: File.Input -> State TransformState Text
processAutorequireContent autorequireContent = do
modify $ \s -> s
{ tstLineTagPrepend = prependLineTag
, tstAutorequire = AutorequireDisabled
}
processed <- File.inputLines autorequireContent
& mapM (process (gets tstHostModule))
& fmap mconcat
modify $ \s -> s { tstLineTagPrepend = prependLineTag }
pure processed
renderImport
:: MonadState TransformState m
=> m (Maybe ModuleName)
-> File.LineTag
-> RequireInfo
-> m Text
renderImport getHostModule line RequireInfo {..} = do
mhostModule <- getHostModule
lineTagPrep <- gets tstLineTagPrepend
let (res, prep) =
if mhostModule == Just riFullModuleName
then ("", prependLineTag)
else (typesImport <> renderLineTag line <> qualifiedImport, ignoreLineTag)
modify $ \s -> s { tstLineTagPrepend = prep }
pure $ lineTagPrep line res
where
typesImport = unwords
[ "import"
, unModuleName riFullModuleName
, "(" <> riImportedTypes <> ")"
] <> "\n"
qualifiedImport = unwords
[ "import qualified"
, unModuleName riFullModuleName
, "as"
, riModuleAlias
] <> "\n"