{-|
Module      : Compiler.RLPC
Description : Tools used to glue each piece of RLPC together

This module implements the toolset common to the entire compiler, most notably
errors and the family of RLPC monads.
-}
{-# LANGUAGE GeneralisedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
-- only used for mtl instances
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
module Compiler.RLPC
    ( RLPC
    , RLPCT
    , RLPCIO
    , RLPCOptions(RLPCOptions)
    , RlpcError(..)
    , addFatal
    , addWound
    , MonadErrorful
    , Severity(..)
    , Evaluator(..)
    , evalRLPCT
    , evalRLPCIO
    , evalRLPC
    , addRlpcWound
    , addRlpcFatal
    , liftRlpcErrs
    , rlpcLogFile
    , rlpcDebugOpts
    , rlpcEvaluator
    , rlpcInputFiles
    , DebugFlag(..)
    , whenFlag
    , flagDDumpEval
    , flagDDumpOpts
    , flagDDumpAST
    , def
    )
    where
----------------------------------------------------------------------------------
import Control.Arrow            ((>>>))
import Control.Exception
import Control.Monad.Reader
import Control.Monad.State      (MonadState(state))
import Control.Monad.Errorful
import Compiler.RlpcError
import Data.Functor.Identity
import Data.Default.Class
import GHC.Generics             (Generic)
import Data.Hashable            (Hashable)
import Data.HashSet             (HashSet)
import Data.HashSet             qualified as S
import Data.Coerce
import Lens.Micro
import Lens.Micro.TH
----------------------------------------------------------------------------------

-- TODO: fancy errors
newtype RLPCT e m a = RLPCT {
        runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
    }
    -- TODO: incorrect ussage of MonadReader. RLPC should have its own
    -- environment access functions
    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)

deriving instance (MonadIO m) => MonadIO (RLPCT e m)

instance MonadTrans (RLPCT e) where
    lift = RLPCT . lift . lift

instance (MonadState s m) => MonadState s (RLPCT e m) where
    state = lift . state

type RLPC e = RLPCT e Identity

type RLPCIO e = RLPCT e IO

evalRLPCT :: RLPCOptions
          -> RLPCT e m a
          -> m (Either e (a, [e]))
evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT

evalRLPC :: RLPCOptions
         -> RLPC e a
         -> Either e (a, [e])
evalRLPC o m = coerce $ evalRLPCT o m

evalRLPCIO :: (Exception e)
           => RLPCOptions
           -> RLPCIO e a
           -> IO (a, [e])
evalRLPCIO o m = do
    m' <- evalRLPCT o m
    case m' of
        -- TODO: errors
        Left e -> throwIO e
        Right a -> pure a
    

data RLPCOptions = RLPCOptions
    { _rlpcLogFile     :: Maybe FilePath
    , _rlpcDebugOpts   :: DebugOpts
    , _rlpcEvaluator   :: Evaluator
    , _rlpcHeapTrigger :: Int
    , _rlpcInputFiles  :: [FilePath]
    }
    deriving Show

data Evaluator = EvaluatorGM | EvaluatorTI
    deriving Show

data Severity = Error
              | Warning
              | Debug
              deriving Show

-- temporary until we have a new doc building system
type ErrorDoc = String

instance (Monad m) => MonadErrorful e (RLPCT e m) where
    addWound = RLPCT . lift . addWound
    addFatal = RLPCT . lift . addFatal

liftRlpcErrs :: (IsRlpcError e, Monad m)
             => RLPCT e m a -> RLPCT RlpcError m a
liftRlpcErrs m = RLPCT . ReaderT $ \r ->
    mapErrors liftRlpcErr $ runRLPCT >>> (`runReaderT` r) $ m

addRlpcWound :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
addRlpcWound = addWound . liftRlpcErr

addRlpcFatal :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
addRlpcFatal = addWound . liftRlpcErr

----------------------------------------------------------------------------------

instance Default RLPCOptions where
    def = RLPCOptions
        { _rlpcLogFile = Nothing
        , _rlpcDebugOpts = mempty
        , _rlpcEvaluator = EvaluatorGM
        , _rlpcHeapTrigger = 200
        , _rlpcInputFiles = []
        }

type DebugOpts = HashSet DebugFlag

data DebugFlag = DDumpEval
               | DDumpOpts
               | DDumpAST
               deriving (Show, Eq, Generic)

instance Hashable DebugFlag

makeLenses ''RLPCOptions
pure []

whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()

-- there's probably a better way to write this. my current knowledge of lenses
-- is too weak.
flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d

flagDDumpEval :: SimpleGetter RLPCOptions Bool
flagDDumpEval = flagGetter DDumpEval

flagDDumpOpts :: SimpleGetter RLPCOptions Bool
flagDDumpOpts = flagGetter DDumpOpts

flagDDumpAST :: SimpleGetter RLPCOptions Bool
flagDDumpAST = flagGetter DDumpAST