Run.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Lentil.Parse.Run
-- Copyright   :  © 2015 Francesco Ariis
-- License     :  GPLv3 (see the LICENSE file)
--
-- Parsing functions interface
-----------------------------------------------------------------------------

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}

module Lentil.Parse.Run where

import Lentil.Types
import Lentil.Helpers
import Lentil.Parse.Issue
import Lentil.Parse.Source
import Lentil.Parse.Syntaxes

import Text.Megaparsec

import qualified Control.Exception    as E
import qualified Control.DeepSeq      as DS
import qualified Control.Monad        as CM
import qualified Control.Monad.Reader as R
import qualified Control.Monad.Trans  as T
import qualified Data.DList           as D
import qualified Data.IORef           as I
import qualified Data.Text            as T
import qualified Data.Text.IO         as TI
import qualified Data.Text.Lazy       as TL
import qualified System.Directory     as D
import qualified System.ProgressBar   as PB

-----------
-- TYPES --
-----------

data RunEnv = RunEnv
            { -- reader part
              reAliases :: [Alias],    -- for parsing purposes
              reFWords  :: [FlagWord], -- for parsing purposes

              -- stateful part
              reFiles   :: I.IORef [FilePath],      -- fnames to process
              reIssues  :: I.IORef (D.DList Issue), -- processed issues
              reBar     :: PB.ProgressBar () }      -- progress bar

newtype Runner a = Runner { runRunner :: R.ReaderT RunEnv IO a }
            deriving (Functor, Applicative, Monad,
                      T.MonadIO, R.MonadReader RunEnv)


issueFinder :: [Alias] -> [FlagWord] -> [FilePath] -> IO [Issue]
issueFinder as fws fps =
            creaEnv >>= \e ->
            let r = runRunner runnerFinder in
            R.runReaderT r e
    where
          creaEnv :: IO RunEnv
          creaEnv =
                let bIO = initProgressBar (length fps) in
                I.newIORef fps     >>= \ifs ->
                I.newIORef D.empty >>= \iis ->
                R.liftIO bIO       >>= \pb ->
                return (RunEnv as fws
                               ifs iis pb)


runnerFinder :: Runner [Issue]
runnerFinder = looperino                    >>
               D.toList <$> asksIO reIssues
    where
          looperino :: Runner ()
          looperino =
                asksIO reFiles >>= \case
                  [] -> return ()
                  _  -> processFile >>
                        looperino

processFile :: Runner ()
processFile = -- 1. does exist
              fetchFile        >>= \fp ->
              doesFileExist fp >>= \bf ->
              if not bf
                then return ()
              else

              -- 2. execute parse (and store results)
              parseFile fp >>

              -- 3. update counter and blit it
              blitCounter


-------------
-- PARSING --
-------------

parseFile :: FilePath -> Runner ()
parseFile fp =
        -- 1. language parser finder
        R.asks reAliases >>= \as ->
        case langParserAlias as fp of
          Nothing -> return ()
          Just p  -> -- 2. parse comments
                     parseComments fp p >>= \cs ->
                     -- 3. parse issues (and write them)
                     mapM_ (parseIssues fp) cs

parseComments :: FilePath -> StateParser () [CommentString] ->
                 Runner [Comment]
parseComments fp p =
            T.liftIO (safeRead fp) >>= \t ->
            runPar (comms2Tuple <$> p) fp () t
            -- meglio di
            -- comms2Tuple <$> runPar p fp () t
            -- così evitiamo istanza deepseq per CommentString

-- from a single comment
parseIssues :: FilePath -> (Row, String) -> Runner ()
parseIssues fp (r, cs) =
            -- parse
            R.asks reFWords         >>= \fws ->
            runPar issPar fp fws cs >>= \dis ->

            -- write
            let appd bd = D.append bd dis      in
            R.asks reIssues                    >>= \iis ->
            T.liftIO (I.modifyIORef' iis appd)
    where
          issPar :: StateParser [FlagWord] (D.DList Issue)
          issPar = D.fromList <$> (setRow r >> issues)

-- generic parsing
runPar :: (Monoid o, DS.NFData o) =>
          StateParser s o -> FilePath -> s -> String -> Runner o
runPar p fp s i =
        case runStateParser p s fp i of
          Left l  -> rperr (fp ++ " : parse error " ++
                            errorBundlePretty l)       >>
                     return mempty
          Right r -> return (DS.deepseq r r)

-- todo [refactor] Row should be carried on by issues, not be manually set!
setRow :: Row -> ParIssue ()
setRow r = updateParserState
             (\(State i o (PosState pix po (SourcePos n _ cx) tw lp) es) ->
                let l' = mkPos r in
               State i o (PosState pix po (SourcePos n l' cx) tw lp) es)


------------------
-- PROGRESS BAR --
------------------

blitCounter :: Runner ()
blitCounter = R.asks reBar                   >>= \pb ->
              T.liftIO (PB.incProgress pb 1)

-- t: total issues
initProgressBar :: Int -> IO (PB.ProgressBar ())
initProgressBar t = PB.newProgressBar myBar 2 (PB.Progress 0 t ())
    where
          myBar = PB.defStyle {
                    PB.styleDone = '*',
                    PB.styleCurrent = '*',
                    PB.styleTodo = ' ',
                    PB.styleWidth = PB.ConstantWidth 40,
                    PB.stylePrefix = PB.msg barMes
                    }

          barMes = TL.pack $ show t ++ " source files"


-----------------
-- ANCILLARIES --
-----------------

asksIO :: (RunEnv -> I.IORef a) -> Runner a
asksIO a = R.asks a                >>= \ia ->
           T.liftIO (I.readIORef ia)

fetchFile :: Runner FilePath
fetchFile = asksIO reFiles >>= \case
              []     -> error "(assert) fetchFile called on empty filelist!"
              (f:fs) -> R.asks reFiles               >>= \ifs ->
                        T.liftIO (I.writeIORef ifs fs) >>
                        return f

doesFileExist :: FilePath -> Runner Bool
doesFileExist fp =
            T.liftIO (D.doesFileExist fp)             >>= \fb ->
            CM.unless fb
                    (rperr $ fp ++ " : no such file") >>
            return fb

rperr :: String -> Runner ()
rperr s = T.liftIO $ perr s

safeRead :: FilePath -> IO String
safeRead fp = E.try (TI.readFile fp) >>= \case
                Right t -> return (T.unpack t)
                Left x  -> perr (fp ++ " : " ++ show (x :: E.IOException) ++
                                 " -- ignoring file") >>
                           return ""