{-# LANGUAGE FlexibleContexts #-}

module Language.Dickinson.File ( evalIO
                               , evalFile
                               , checkFile
                               , validateFile
                               , validateBSL
                               , validateAmalgamate
                               , warnFile
                               , warnBSL
                               , patternExhaustivenessFile
                               , patternExhaustivenessBSL
                               , tcFile
                               , amalgamateRename
                               , amalgamateRenameM
                               , pipeline
                               , pipelineBSL
                               , pipelineBSLErr
                               , resolveFile
                               ) where

import           Control.Applicative                  ((<|>))
import           Control.Composition                  ((.*), (.**), (<=*<))
import           Control.Exception                    (Exception)
import           Control.Exception.Value
import           Control.Monad                        (void, (<=<))
import           Control.Monad.Except                 (ExceptT, MonadError, runExceptT)
import           Control.Monad.IO.Class               (MonadIO)
import           Control.Monad.State                  (MonadState, StateT, evalStateT)
import           Data.Bifunctor                       (first)
import qualified Data.ByteString.Lazy                 as BSL
import           Data.Functor                         (($>))
import           Data.Text                            as T
import           Data.Text.Prettyprint.Doc.Ext        (prettyText)
import           Language.Dickinson.Check
import           Language.Dickinson.Check.Duplicate
import           Language.Dickinson.Check.Exhaustive
import           Language.Dickinson.Check.Scope
import           Language.Dickinson.Error
import           Language.Dickinson.Eval
import           Language.Dickinson.Lexer
import           Language.Dickinson.Parser
import           Language.Dickinson.Pipeline
import           Language.Dickinson.Rename
import           Language.Dickinson.Rename.Amalgamate
import           Language.Dickinson.Type
import           Language.Dickinson.TypeCheck
import           System.Random                        (StdGen, newStdGen, randoms)

data AmalgamateSt = AmalgamateSt { AmalgamateSt -> Renames
amalgamateRenames    :: Renames
                                 , AmalgamateSt -> AlexUserState
amalgamateLexerState :: AlexUserState
                                 }

type AllM = StateT (EvalSt AlexPosn) (ExceptT (DickinsonError AlexPosn) IO)

evalIO :: AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO :: forall x. AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO AllM x
me = (\StdGen
g -> forall x.
StdGen -> AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalAllWithGen StdGen
g AllM x
me) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => m StdGen
newStdGen

evalAllWithGen :: StdGen
               -> AllM x
               -> IO (Either (DickinsonError AlexPosn) x)
evalAllWithGen :: forall x.
StdGen -> AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalAllWithGen StdGen
g AllM x
me = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT AllM x
me (forall a.
[Double]
-> IntMap (Expression a)
-> Renames
-> Map Text Unique
-> AlexUserState
-> TyEnv a
-> IntMap (NonEmpty (TyName a))
-> EvalSt a
EvalSt (forall a g. (Random a, RandomGen g) => g -> [a]
randoms StdGen
g) forall a. Monoid a => a
mempty Renames
initRenames forall a. Monoid a => a
mempty AlexUserState
alexInitUserState forall a. TyEnv a
emptyTyEnv forall a. Monoid a => a
mempty)

initAmalgamateSt :: AmalgamateSt
initAmalgamateSt :: AmalgamateSt
initAmalgamateSt = Renames -> AlexUserState -> AmalgamateSt
AmalgamateSt Renames
initRenames AlexUserState
alexInitUserState

instance HasLexerState AmalgamateSt where
    lexerStateLens :: Lens' AmalgamateSt AlexUserState
lexerStateLens AlexUserState -> f AlexUserState
f AmalgamateSt
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\AlexUserState
x -> AmalgamateSt
s { amalgamateLexerState :: AlexUserState
amalgamateLexerState = AlexUserState
x }) (AlexUserState -> f AlexUserState
f (AmalgamateSt -> AlexUserState
amalgamateLexerState AmalgamateSt
s))

instance HasRenames AmalgamateSt where
    rename :: Lens' AmalgamateSt Renames
rename Renames -> f Renames
f AmalgamateSt
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Renames
x -> AmalgamateSt
s { amalgamateRenames :: Renames
amalgamateRenames = Renames
x }) (Renames -> f Renames
f (AmalgamateSt -> Renames
amalgamateRenames AmalgamateSt
s))

amalgamateRenameM :: (HasRenames s, HasLexerState s, MonadIO m, MonadError (DickinsonError AlexPosn) m, MonadState s m)
                  => [FilePath]
                  -> FilePath
                  -> m [Declaration AlexPosn]
amalgamateRenameM :: forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> m [Declaration AlexPosn]
amalgamateRenameM [FilePath]
is = (forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadState s m) =>
m ()
balanceMax forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
(MonadState s m, HasRenames s) =>
[Declaration a] -> m [Declaration a]
renameDeclarationsM forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall s (m :: * -> *).
(HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> m [Declaration AlexPosn]
fileDecls [FilePath]
is

amalgamateRenameInpM :: (HasRenames s, HasLexerState s, MonadIO m, MonadError (DickinsonError AlexPosn) m, MonadState s m)
                     => [FilePath]
                     -> FilePath -- ^ For error reporting
                     -> BSL.ByteString
                     -> m [Declaration AlexPosn]
amalgamateRenameInpM :: forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> ByteString -> m [Declaration AlexPosn]
amalgamateRenameInpM [FilePath]
is = (forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadState s m) =>
m ()
balanceMax forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
(MonadState s m, HasRenames s) =>
[Declaration a] -> m [Declaration a]
renameDeclarationsM forall (m :: * -> *) c d a b.
Monad m =>
(c -> m d) -> (a -> b -> m c) -> a -> b -> m d
<=*< forall s (m :: * -> *).
(HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> ByteString -> m [Declaration AlexPosn]
bslDecls [FilePath]
is

amalgamateRename :: [FilePath]
                 -> FilePath
                 -> IO [Declaration AlexPosn]
amalgamateRename :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]
amalgamateRename [FilePath]
is FilePath
fp = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT AmalgamateSt
initAmalgamateSt forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e x. Exception e => Either e x -> x
eitherThrow forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> m [Declaration AlexPosn]
amalgamateRenameM [FilePath]
is FilePath
fp

amalgamateRenameBSL :: [FilePath]
                    -> FilePath -- ^ For error reporting
                    -> BSL.ByteString
                    -> IO [Declaration AlexPosn]
amalgamateRenameBSL :: [FilePath] -> FilePath -> ByteString -> IO [Declaration AlexPosn]
amalgamateRenameBSL [FilePath]
is FilePath
fp ByteString
bsl = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT AmalgamateSt
initAmalgamateSt forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e x. Exception e => Either e x -> x
eitherThrow forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> ByteString -> m [Declaration AlexPosn]
amalgamateRenameInpM [FilePath]
is FilePath
fp ByteString
bsl

-- | Check scoping
checkFile :: [FilePath] -> FilePath -> IO ()
checkFile :: [FilePath] -> FilePath -> IO ()
checkFile = forall e.
Exception e =>
([Declaration AlexPosn] -> Maybe e)
-> [FilePath] -> FilePath -> IO ()
ioChecker forall a. [Declaration a] -> Maybe (DickinsonError a)
checkScope

-- | Check scoping and types
validateFile :: [FilePath] -> FilePath -> IO ()
validateFile :: [FilePath] -> FilePath -> IO ()
validateFile = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* [FilePath] -> FilePath -> IO [Declaration AlexPosn]
validateAmalgamate

-- | Check scoping and types
--
-- @since 1.4.1.0
validateBSL :: [FilePath] -> FilePath -> BSL.ByteString -> IO ()
validateBSL :: [FilePath] -> FilePath -> ByteString -> IO ()
validateBSL = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.** [FilePath] -> FilePath -> ByteString -> IO [Declaration AlexPosn]
validateAmalgamateBSL

validateAmalgamate :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]
validateAmalgamate :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]
validateAmalgamate [FilePath]
is FilePath
fp = do
    [Declaration AlexPosn]
d <- [FilePath] -> FilePath -> IO [Declaration AlexPosn]
amalgamateRename [FilePath]
is FilePath
fp
    forall e. Exception e => Maybe e -> IO ()
maybeThrowIO forall a b. (a -> b) -> a -> b
$ forall a. [Declaration a] -> Maybe (DickinsonError a)
checkScope [Declaration AlexPosn]
d
    forall e x. Exception e => Either e x -> IO x
eitherThrowIO (forall a. [Declaration a] -> Either (DickinsonError a) ()
tyRun [Declaration AlexPosn]
d) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Declaration AlexPosn]
d

validateAmalgamateBSL :: [FilePath] -> FilePath -> BSL.ByteString -> IO [Declaration AlexPosn]
validateAmalgamateBSL :: [FilePath] -> FilePath -> ByteString -> IO [Declaration AlexPosn]
validateAmalgamateBSL [FilePath]
is FilePath
fp ByteString
bsl = do
    [Declaration AlexPosn]
d <- [FilePath] -> FilePath -> ByteString -> IO [Declaration AlexPosn]
amalgamateRenameBSL [FilePath]
is FilePath
fp ByteString
bsl
    forall e. Exception e => Maybe e -> IO ()
maybeThrowIO forall a b. (a -> b) -> a -> b
$ forall a. [Declaration a] -> Maybe (DickinsonError a)
checkScope [Declaration AlexPosn]
d
    forall e x. Exception e => Either e x -> IO x
eitherThrowIO (forall a. [Declaration a] -> Either (DickinsonError a) ()
tyRun [Declaration AlexPosn]
d) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Declaration AlexPosn]
d

warnFile :: FilePath -> IO ()
warnFile :: FilePath -> IO ()
warnFile = ByteString -> IO ()
warnBSL forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< FilePath -> IO ByteString
BSL.readFile

-- | Run some lints
--
-- @since 1.4.2.0
warnBSL :: BSL.ByteString -> IO ()
warnBSL :: ByteString -> IO ()
warnBSL = forall e. Exception e => Maybe e -> IO ()
maybeThrowIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Declaration AlexPosn]
x -> forall a. [Declaration a] -> Maybe (DickinsonWarning a)
checkDuplicates [Declaration AlexPosn]
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. [Declaration a] -> Maybe (DickinsonWarning a)
checkMultiple [Declaration AlexPosn]
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Dickinson a -> [Declaration a]
modDefs
    forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e x. Exception e => Either e x -> IO x
eitherThrowIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either (ParseError AlexPosn) (Dickinson AlexPosn)
parse

ioChecker :: Exception e => ([Declaration AlexPosn] -> Maybe e) -> [FilePath] -> FilePath -> IO ()
ioChecker :: forall e.
Exception e =>
([Declaration AlexPosn] -> Maybe e)
-> [FilePath] -> FilePath -> IO ()
ioChecker [Declaration AlexPosn] -> Maybe e
checker [FilePath]
is = forall e. Exception e => Maybe e -> IO ()
maybeThrowIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Declaration AlexPosn] -> Maybe e
checker forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [FilePath] -> FilePath -> IO [Declaration AlexPosn]
amalgamateRename [FilePath]
is

tcFile :: [FilePath] -> FilePath -> IO ()
tcFile :: [FilePath] -> FilePath -> IO ()
tcFile [FilePath]
is = forall e x. Exception e => Either e x -> IO x
eitherThrowIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Declaration a] -> Either (DickinsonError a) ()
tyRun forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [FilePath] -> FilePath -> IO [Declaration AlexPosn]
amalgamateRename [FilePath]
is

patternExhaustivenessFile :: [FilePath] -- ^ Includes
                          -> FilePath
                          -> IO ()
patternExhaustivenessFile :: [FilePath] -> FilePath -> IO ()
patternExhaustivenessFile [FilePath]
is = forall e. Exception e => Maybe e -> IO ()
maybeThrowIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Declaration a] -> Maybe (DickinsonWarning a)
checkExhaustive forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [FilePath] -> FilePath -> IO [Declaration AlexPosn]
amalgamateRename [FilePath]
is

-- | @since 1.4.1.0
patternExhaustivenessBSL :: [FilePath] -- ^ Includes
                         -> FilePath -- ^ Source file (for error reporting)
                         -> BSL.ByteString
                         -> IO ()
patternExhaustivenessBSL :: [FilePath] -> FilePath -> ByteString -> IO ()
patternExhaustivenessBSL [FilePath]
is = forall e. Exception e => Maybe e -> IO ()
maybeThrowIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Declaration a] -> Maybe (DickinsonWarning a)
checkExhaustive forall (m :: * -> *) c d a b.
Monad m =>
(c -> m d) -> (a -> b -> m c) -> a -> b -> m d
<=*< [FilePath] -> FilePath -> ByteString -> IO [Declaration AlexPosn]
amalgamateRenameBSL [FilePath]
is

evalFile :: [FilePath] -> FilePath -> IO T.Text
evalFile :: [FilePath] -> FilePath -> IO Text
evalFile [FilePath]
is FilePath
fp = (\StdGen
g -> StdGen -> [FilePath] -> FilePath -> IO Text
evalFileGen StdGen
g [FilePath]
is FilePath
fp) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => m StdGen
newStdGen

evalFileGen :: StdGen -> [FilePath] -> FilePath -> IO T.Text
evalFileGen :: StdGen -> [FilePath] -> FilePath -> IO Text
evalFileGen StdGen
g [FilePath]
is = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e x. Exception e => Either e x -> x
eitherThrow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x.
StdGen -> AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalAllWithGen StdGen
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
[Declaration a] -> m Text
evalDickinsonAsMain forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> m [Declaration AlexPosn]
amalgamateRenameM [FilePath]
is)

resolveFile :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]
resolveFile :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]
resolveFile [FilePath]
is = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e x. Exception e => Either e x -> x
eitherThrow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Declaration a -> m (Declaration a)
resolveDeclarationM forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> m [Declaration AlexPosn]
amalgamateRenameM [FilePath]
is)

pipeline :: [FilePath] -> FilePath -> IO T.Text
pipeline :: [FilePath] -> FilePath -> IO Text
pipeline [FilePath]
is FilePath
fp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e x. Exception e => Either e x -> x
eitherThrow forall a b. (a -> b) -> a -> b
$ forall x. AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO forall a b. (a -> b) -> a -> b
$
    forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
[Declaration a] -> m Text
checkEvalM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> m [Declaration AlexPosn]
amalgamateRenameM [FilePath]
is FilePath
fp

-- | @since 1.4.2.0
pipelineBSLErr :: [FilePath]
               -> FilePath -- ^ For error reporting
               -> BSL.ByteString
               -> IO (Either T.Text T.Text)
pipelineBSLErr :: [FilePath] -> FilePath -> ByteString -> IO (Either Text Text)
pipelineBSLErr [FilePath]
is FilePath
fp ByteString
bsl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
prettyText) forall a b. (a -> b) -> a -> b
$ forall x. AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO forall a b. (a -> b) -> a -> b
$
    forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
[Declaration a] -> m Text
checkEvalM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> ByteString -> m [Declaration AlexPosn]
amalgamateRenameInpM [FilePath]
is FilePath
fp ByteString
bsl

-- | @since 1.4.1.0
pipelineBSL :: [FilePath]
            -> FilePath -- ^ For error reporting
            -> BSL.ByteString
            -> IO T.Text
pipelineBSL :: [FilePath] -> FilePath -> ByteString -> IO Text
pipelineBSL [FilePath]
is FilePath
fp ByteString
bsl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e x. Exception e => Either e x -> x
eitherThrow forall a b. (a -> b) -> a -> b
$ forall x. AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO forall a b. (a -> b) -> a -> b
$
    forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
[Declaration a] -> m Text
checkEvalM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadIO m,
 MonadError (DickinsonError AlexPosn) m, MonadState s m) =>
[FilePath] -> FilePath -> ByteString -> m [Declaration AlexPosn]
amalgamateRenameInpM [FilePath]
is FilePath
fp ByteString
bsl