language-dickinson-1.4.1.0: src/Language/Dickinson/File.hs
{-# LANGUAGE FlexibleContexts #-}
module Language.Dickinson.File ( evalIO
, evalFile
, checkFile
, validateFile
, validateBSL
, validateAmalgamate
, warnFile
, warnBSL
, patternExhaustivenessFile
, patternExhaustivenessBSL
, tcFile
, amalgamateRename
, amalgamateRenameM
, pipeline
, pipelineBSL
, 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 qualified Data.ByteString.Lazy as BSL
import Data.Functor (($>))
import Data.Text as T
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 { amalgamateRenames :: Renames
, amalgamateLexerState :: AlexUserState
}
type AllM = StateT (EvalSt AlexPosn) (ExceptT (DickinsonError AlexPosn) IO)
evalIO :: AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO me = (\g -> evalAllWithGen g me) =<< newStdGen
evalAllWithGen :: StdGen
-> AllM x
-> IO (Either (DickinsonError AlexPosn) x)
evalAllWithGen g me = runExceptT $ evalStateT me (EvalSt (randoms g) mempty initRenames mempty alexInitUserState emptyTyEnv mempty)
initAmalgamateSt :: AmalgamateSt
initAmalgamateSt = AmalgamateSt initRenames alexInitUserState
instance HasLexerState AmalgamateSt where
lexerStateLens f s = fmap (\x -> s { amalgamateLexerState = x }) (f (amalgamateLexerState s))
instance HasRenames AmalgamateSt where
rename f s = fmap (\x -> s { amalgamateRenames = x }) (f (amalgamateRenames s))
amalgamateRenameM :: (HasRenames s, HasLexerState s, MonadIO m, MonadError (DickinsonError AlexPosn) m, MonadState s m)
=> [FilePath]
-> FilePath
-> m [Declaration AlexPosn]
amalgamateRenameM is = (balanceMax *>) . renameDeclarationsM <=< fileDecls 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 is = (balanceMax *>) . renameDeclarationsM <=*< bslDecls is
amalgamateRename :: [FilePath]
-> FilePath
-> IO [Declaration AlexPosn]
amalgamateRename is fp = flip evalStateT initAmalgamateSt $ fmap eitherThrow $ runExceptT $ amalgamateRenameM is fp
amalgamateRenameBSL :: [FilePath]
-> FilePath -- ^ For error reporting
-> BSL.ByteString
-> IO [Declaration AlexPosn]
amalgamateRenameBSL is fp bsl = flip evalStateT initAmalgamateSt $ fmap eitherThrow $ runExceptT $ amalgamateRenameInpM is fp bsl
-- | Check scoping
checkFile :: [FilePath] -> FilePath -> IO ()
checkFile = ioChecker checkScope
-- | Check scoping and types
validateFile :: [FilePath] -> FilePath -> IO ()
validateFile = void .* validateAmalgamate
-- | Check scoping and types
--
-- @since 1.4.1.0
validateBSL :: [FilePath] -> FilePath -> BSL.ByteString -> IO ()
validateBSL = void .** validateAmalgamateBSL
validateAmalgamate :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]
validateAmalgamate is fp = do
d <- amalgamateRename is fp
maybeThrowIO $ checkScope d
eitherThrowIO (tyRun d) $> d
validateAmalgamateBSL :: [FilePath] -> FilePath -> BSL.ByteString -> IO [Declaration AlexPosn]
validateAmalgamateBSL is fp bsl = do
d <- amalgamateRenameBSL is fp bsl
maybeThrowIO $ checkScope d
eitherThrowIO (tyRun d) $> d
warnFile :: FilePath -> IO ()
warnFile = warnBSL <=< BSL.readFile
-- | Run some lints
--
-- @since 1.4.2.0
warnBSL :: BSL.ByteString -> IO ()
warnBSL = maybeThrowIO . (\x -> checkDuplicates x <|> checkMultiple x) . modDefs
<=< eitherThrowIO . parse
ioChecker :: Exception e => ([Declaration AlexPosn] -> Maybe e) -> [FilePath] -> FilePath -> IO ()
ioChecker checker is = maybeThrowIO . checker <=< amalgamateRename is
tcFile :: [FilePath] -> FilePath -> IO ()
tcFile is = eitherThrowIO . tyRun <=< amalgamateRename is
patternExhaustivenessFile :: [FilePath] -- ^ Includes
-> FilePath
-> IO ()
patternExhaustivenessFile is = maybeThrowIO . checkExhaustive <=< amalgamateRename is
-- | @since 1.4.1.0
patternExhaustivenessBSL :: [FilePath] -- ^ Includes
-> FilePath -- ^ Source file (for error reporting)
-> BSL.ByteString
-> IO ()
patternExhaustivenessBSL is = maybeThrowIO . checkExhaustive <=*< amalgamateRenameBSL is
evalFile :: [FilePath] -> FilePath -> IO T.Text
evalFile is fp = (\g -> evalFileGen g is fp) =<< newStdGen
evalFileGen :: StdGen -> [FilePath] -> FilePath -> IO T.Text
evalFileGen g is = fmap eitherThrow . evalAllWithGen g . (evalDickinsonAsMain <=< amalgamateRenameM is)
resolveFile :: [FilePath] -> FilePath -> IO [Declaration AlexPosn]
resolveFile is = fmap eitherThrow . evalIO . (traverse resolveDeclarationM <=< amalgamateRenameM is)
pipeline :: [FilePath] -> FilePath -> IO T.Text
pipeline is fp = fmap eitherThrow $ evalIO $
checkEvalM =<< amalgamateRenameM is fp
-- | @since 1.4.1.0
pipelineBSL :: [FilePath]
-> FilePath -- ^ For error reporting
-> BSL.ByteString
-> IO T.Text
pipelineBSL is fp bsl = fmap eitherThrow $ evalIO $
checkEvalM =<< amalgamateRenameInpM is fp bsl