{-# 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


-- | The monad stack used during transformation:
--
-- * @'StateT' 'TransformState'@ to keep track of whether to render the next
--   line tag, the module's name etc.
-- * @'WriterT' ('DList' 'Text')@ to collect the output lines. Instead of
--   haskell's built-in list type we use 'DList' because of it's /O(1)/ append
--   operation.
-- * @'Either' 'Error'@ to return errors.
type TransformM =
  StateT TransformState
    (WriterT (DList Text)
      (Either Error))


data TransformState = TransformState
  { TransformState -> LineTag -> TransformM ()
tstLineTagOutput  :: File.LineTag -> TransformM ()
  , TransformState -> Maybe ModuleName
tstHostModule     :: !(Maybe ModuleName)
  , TransformState -> AutorequireMode Input
tstAutorequire    :: !(AutorequireMode File.Input)
  }


-- | Outputs a single line.
output :: Text -> TransformM ()
output :: Text -> TransformM ()
output = DList Text -> TransformM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (DList Text -> TransformM ())
-> (Text -> DList Text) -> Text -> TransformM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DList Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Outputs the pragma representation of the given line tag.
renderLineTag :: File.LineTag -> TransformM ()
renderLineTag :: LineTag -> TransformM ()
renderLineTag (File.LineTag (File.Name Text
fn) (File.LineNumber Int
ln)) =
  Text -> TransformM ()
output (Text -> TransformM ()) -> Text -> TransformM ()
forall a b. (a -> b) -> a -> b
$ Text
"{-# LINE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
ln Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" #-}"

-- | Ignore the given line tag, specifically don't render it.
ignoreLineTag :: File.LineTag -> TransformM ()
ignoreLineTag :: LineTag -> TransformM ()
ignoreLineTag = TransformM () -> LineTag -> TransformM ()
forall a b. a -> b -> a
const (() -> TransformM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())


transform :: AutorequireMode File.Input -> File.Input -> Either Error [Text]
transform :: AutorequireMode Input -> Input -> Either Error [Text]
transform AutorequireMode Input
autorequire Input
input =
  Input -> [(LineTag, Text)]
File.inputLines Input
input
    [(LineTag, Text)]
-> ([(LineTag, Text)] -> TransformM ()) -> TransformM ()
forall a b. a -> (a -> b) -> b
& ((LineTag, Text) -> TransformM ())
-> [(LineTag, Text)] -> TransformM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool -> (LineTag, Text) -> TransformM ()
process Bool
False)
    TransformM ()
-> (TransformM ()
    -> WriterT (DList Text) (Either Error) TransformState)
-> WriterT (DList Text) (Either Error) TransformState
forall a b. a -> (a -> b) -> b
& (TransformM ()
 -> TransformState
 -> WriterT (DList Text) (Either Error) TransformState)
-> TransformState
-> TransformM ()
-> WriterT (DList Text) (Either Error) TransformState
forall a b c. (a -> b -> c) -> b -> a -> c
flip TransformM ()
-> TransformState
-> WriterT (DList Text) (Either Error) TransformState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT TransformState
initialState
    WriterT (DList Text) (Either Error) TransformState
-> (WriterT (DList Text) (Either Error) TransformState
    -> WriterT (DList Text) (Either Error) ())
-> WriterT (DList Text) (Either Error) ()
forall a b. a -> (a -> b) -> b
& (TransformState -> WriterT (DList Text) (Either Error) ())
-> WriterT (DList Text) (Either Error) TransformState
-> WriterT (DList Text) (Either Error) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
chainedTo TransformState -> WriterT (DList Text) (Either Error) ()
forall (m :: * -> *). MonadError Error m => TransformState -> m ()
checkDidAutorequire
    WriterT (DList Text) (Either Error) ()
-> (WriterT (DList Text) (Either Error) ()
    -> Either Error (DList Text))
-> Either Error (DList Text)
forall a b. a -> (a -> b) -> b
& WriterT (DList Text) (Either Error) () -> Either Error (DList Text)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT
    Either Error (DList Text)
-> (Either Error (DList Text) -> Either Error [Text])
-> Either Error [Text]
forall a b. a -> (a -> b) -> b
& (DList Text -> [Text])
-> Either Error (DList Text) -> Either Error [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DList Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    initialState :: TransformState
initialState = TransformState :: (LineTag -> TransformM ())
-> Maybe ModuleName -> AutorequireMode Input -> TransformState
TransformState
      { tstLineTagOutput :: LineTag -> TransformM ()
tstLineTagOutput  = LineTag -> TransformM ()
renderLineTag
      , tstHostModule :: Maybe ModuleName
tstHostModule     = Maybe ModuleName
forall a. Maybe a
Nothing
      , tstAutorequire :: AutorequireMode Input
tstAutorequire    = AutorequireMode Input
autorequire
      }

    unableToAutorequire :: TransformState -> Bool
unableToAutorequire TransformState
resultState
      -- If the autorequire mode was `enabled` initially and still is
      -- afterwards, we were unable to find where to place the Require contents.
      | AutorequireEnabled Input
_ <- AutorequireMode Input
autorequire
      , AutorequireEnabled Input
_ <- TransformState -> AutorequireMode Input
tstAutorequire TransformState
resultState
      = Bool
True
      -- In any other case this either wasn't goal or it was done successfully.
      | Bool
otherwise
      = Bool
False

    checkDidAutorequire :: TransformState -> m ()
checkDidAutorequire TransformState
resultState
      | TransformState -> Bool
unableToAutorequire TransformState
resultState = Error -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
AutorequireImpossible
      | Bool
otherwise = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


process :: Bool -> (File.LineTag, Text) -> TransformM ()
process :: Bool -> (LineTag, Text) -> TransformM ()
process Bool
filterImports (LineTag
tag, Text
line) = do
  -- Uses 'tstLineTagOutput' to render the current lines tag if necessary.
  let useTagPrep :: TransformM ()
useTagPrep = do
        TransformState
tst <- StateT
  TransformState (WriterT (DList Text) (Either Error)) TransformState
forall s (m :: * -> *). MonadState s m => m s
get
        TransformState -> LineTag -> TransformM ()
tstLineTagOutput TransformState
tst LineTag
tag
        TransformState -> TransformM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TransformState
tst { tstLineTagOutput :: LineTag -> TransformM ()
tstLineTagOutput = LineTag -> TransformM ()
ignoreLineTag })

  let lineWithAutorequire :: Bool -> Bool -> TransformM ()
lineWithAutorequire Bool
isDirective Bool
autoCondition = do
        AutorequireMode Input
autoMode <- (TransformState -> AutorequireMode Input)
-> StateT
     TransformState
     (WriterT (DList Text) (Either Error))
     (AutorequireMode Input)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TransformState -> AutorequireMode Input
tstAutorequire
        case AutorequireMode Input
autoMode of
          AutorequireEnabled Input
autoContent
            | Bool
isDirective Bool -> Bool -> Bool
|| Bool
autoCondition -> do
                -- If this is an `autorequire` directive, ignore it. Otherwise
                -- output the line tag if necessary (useTagPrep) and then the
                -- line itself.
                Bool -> TransformM () -> TransformM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isDirective (TransformM ()
useTagPrep TransformM () -> TransformM () -> TransformM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> TransformM ()
output Text
line)
                Input -> TransformM ()
processAutorequireContent Input
autoContent

          AutorequireOnDirective (Just Input
autoContent)
            | Bool
isDirective -> Input -> TransformM ()
processAutorequireContent Input
autoContent

          AutorequireOnDirective Maybe Input
Nothing
            | Bool
isDirective -> Error -> TransformM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
MissingOptionalRequiresFile

          AutorequireMode Input
_ | Bool
isDirective -> () -> TransformM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise   -> TransformM ()
useTagPrep TransformM () -> TransformM () -> TransformM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> TransformM ()
output Text
line

  let hasWhere :: Bool
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.
        Text -> [Text]
forall t. IsText t "words" => t -> [t]
words Text
line
          [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"--" Text -> Text -> Bool
`Text.isPrefixOf`))
          [Text] -> ([Text] -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
elem Text
"where"

  case Parsec Void Text RequireDirective -> Text -> Maybe RequireDirective
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Parser.parseMaybe Parsec Void Text RequireDirective
Parser.requireDirective Text
line of
    Maybe RequireDirective
Nothing -> do
      Bool
hasModule <- (TransformState -> Bool)
-> StateT TransformState (WriterT (DList Text) (Either Error)) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((TransformState -> Bool)
 -> StateT
      TransformState (WriterT (DList Text) (Either Error)) Bool)
-> (TransformState -> Bool)
-> StateT TransformState (WriterT (DList Text) (Either Error)) Bool
forall a b. (a -> b) -> a -> b
$ Maybe ModuleName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ModuleName -> Bool)
-> (TransformState -> Maybe ModuleName) -> TransformState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransformState -> Maybe ModuleName
tstHostModule
      Bool -> Bool -> TransformM ()
lineWithAutorequire Bool
False (Bool -> TransformM ()) -> Bool -> TransformM ()
forall a b. (a -> b) -> a -> b
$ Bool
hasModule Bool -> Bool -> Bool
&& Bool
hasWhere

    Just (ModuleDirective ModuleName
moduleName) -> do
      -- If there is already a module name, don't overwrite it.
      (TransformState -> TransformState) -> TransformM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TransformState -> TransformState) -> TransformM ())
-> (TransformState -> TransformState) -> TransformM ()
forall a b. (a -> b) -> a -> b
$ \TransformState
s -> TransformState
s { tstHostModule :: Maybe ModuleName
tstHostModule = TransformState -> Maybe ModuleName
tstHostModule TransformState
s Maybe ModuleName -> Maybe ModuleName -> Maybe ModuleName
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
moduleName }
      Bool -> Bool -> TransformM ()
lineWithAutorequire Bool
False Bool
hasWhere

    Just (RequireDirective RequireInfo
ri) ->
      -- renderImport already prepends the line tag if necessary.
      Bool -> LineTag -> RequireInfo -> TransformM ()
renderImport Bool
filterImports LineTag
tag RequireInfo
ri

    Just RequireDirective
AutorequireDirective ->
      Bool -> Bool -> TransformM ()
lineWithAutorequire Bool
True Bool
False


processAutorequireContent :: File.Input -> TransformM ()
processAutorequireContent :: Input -> TransformM ()
processAutorequireContent Input
autorequireContent = do
  (TransformState -> TransformState) -> TransformM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TransformState -> TransformState) -> TransformM ())
-> (TransformState -> TransformState) -> TransformM ()
forall a b. (a -> b) -> a -> b
$ \TransformState
s -> TransformState
s
     { tstLineTagOutput :: LineTag -> TransformM ()
tstLineTagOutput  = LineTag -> TransformM ()
renderLineTag
     , tstAutorequire :: AutorequireMode Input
tstAutorequire    = AutorequireMode Input
forall a. AutorequireMode a
AutorequireDisabled
     }

  ((LineTag, Text) -> TransformM ())
-> [(LineTag, Text)] -> TransformM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool -> (LineTag, Text) -> TransformM ()
process Bool
True) (Input -> [(LineTag, Text)]
File.inputLines Input
autorequireContent)
  (TransformState -> TransformState) -> TransformM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TransformState -> TransformState) -> TransformM ())
-> (TransformState -> TransformState) -> TransformM ()
forall a b. (a -> b) -> a -> b
$ \TransformState
s -> TransformState
s { tstLineTagOutput :: LineTag -> TransformM ()
tstLineTagOutput = LineTag -> TransformM ()
renderLineTag }


renderImport :: Bool -> File.LineTag -> RequireInfo -> TransformM ()
renderImport :: Bool -> LineTag -> RequireInfo -> TransformM ()
renderImport Bool
filterImports LineTag
line RequireInfo {Text
ModuleName
riImportedTypes :: RequireInfo -> Text
riModuleAlias :: RequireInfo -> Text
riFullModuleName :: RequireInfo -> ModuleName
riImportedTypes :: Text
riModuleAlias :: Text
riFullModuleName :: ModuleName
..} = do
    TransformState
tst <- StateT
  TransformState (WriterT (DList Text) (Either Error)) TransformState
forall s (m :: * -> *). MonadState s m => m s
get
    if Bool
filterImports Bool -> Bool -> Bool
&& TransformState -> Maybe ModuleName
tstHostModule TransformState
tst Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
riFullModuleName
      then
        -- We skipped a line, therefore we need a line tag before outputting
        -- the next one.
        TransformState -> TransformM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TransformState
tst { tstLineTagOutput :: LineTag -> TransformM ()
tstLineTagOutput = LineTag -> TransformM ()
renderLineTag })

      else do
        TransformState -> LineTag -> TransformM ()
tstLineTagOutput TransformState
tst LineTag
line
        Text -> TransformM ()
output Text
typesImport
        LineTag -> TransformM ()
renderLineTag LineTag
line
        Text -> TransformM ()
output Text
qualifiedImport
        TransformState -> TransformM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TransformState
tst { tstLineTagOutput :: LineTag -> TransformM ()
tstLineTagOutput = LineTag -> TransformM ()
ignoreLineTag })
  where
    typesImport :: Text
typesImport = [Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords
      [ Text
"import"
      , ModuleName -> Text
unModuleName ModuleName
riFullModuleName
      , Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
riImportedTypes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      ]
    qualifiedImport :: Text
qualifiedImport = [Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords
      [ Text
"import qualified"
      , ModuleName -> Text
unModuleName ModuleName
riFullModuleName
      , Text
"as"
      , Text
riModuleAlias
      ]