{-# 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 = -- TODO: -- * if the mapM overhead is too much maybe use a streaming library -- * there is no need to concatenate the whole output in memory, a lazy text would be fine -- * maybe we should check if tstAutorequired is set after processing 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 -> -- TODO: Better error reporting. error "Found an `autorequire` directive but no `Requires` file was found." _ | isDirective -> pure "" | otherwise -> useTagPrep $ line <> "\n" let hasWhere = -- TODO: This assumes that comments have whitespace before them and -- that `where` has whitespace before it. But -- module Foo (abc)where--something else -- is valid in Haskell. 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 -- If there is already a module name, don't overwrite it. modify $ \s -> s { tstHostModule = tstHostModule s <|> Just moduleName } lineWithAutorequire False hasWhere Just (RequireDirective ri) -> -- renderImport already prepends the line tag if necessary. 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"