-- |
-- Module      :  Cryptol.Parser.NoInclude
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
module Cryptol.Parser.NoInclude
  ( removeIncludesModule
  , IncludeError(..), ppIncludeError
  ) where

import qualified Control.Applicative as A
import Control.DeepSeq
import qualified Control.Exception as X
import qualified Control.Monad.Fail as Fail

import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.ByteString (ByteString)
import Data.Either (partitionEithers)
import Data.Text(Text)
import qualified Data.Text.Encoding as T (decodeUtf8')
import Data.Text.Encoding.Error (UnicodeException)
import GHC.Generics (Generic)
import MonadLib
import System.Directory (makeAbsolute)
import System.FilePath (takeDirectory,(</>),isAbsolute)

import Cryptol.Utils.PP hiding ((</>))
import Cryptol.Parser (parseProgramWith)
import Cryptol.Parser.AST
import Cryptol.Parser.LexerUtils (Config(..),defaultConfig)
import Cryptol.Parser.ParserUtils
import Cryptol.Parser.Unlit (guessPreProc)
import Cryptol.ModuleSystem.Fingerprint

removeIncludesModule ::
  (FilePath -> IO ByteString) ->
  FilePath ->
  Module PName ->
  IO (Either [IncludeError] (Module PName, Map FilePath Fingerprint))
removeIncludesModule :: (FilePath -> IO ByteString)
-> FilePath
-> Module PName
-> IO (Either [IncludeError] (Module PName, Deps))
removeIncludesModule FilePath -> IO ByteString
reader FilePath
modPath Module PName
m =
  (FilePath -> IO ByteString)
-> FilePath
-> NoIncM (Module PName)
-> IO (Either [IncludeError] (Module PName, Deps))
forall a.
(FilePath -> IO ByteString)
-> FilePath -> NoIncM a -> IO (Either [IncludeError] (a, Deps))
runNoIncM FilePath -> IO ByteString
reader FilePath
modPath (Module PName -> NoIncM (Module PName)
forall mname. ModuleG mname PName -> NoIncM (ModuleG mname PName)
noIncludeModule Module PName
m)

data IncludeError
  = IncludeFailed (Located FilePath)
  | IncludeDecodeFailed (Located FilePath) UnicodeException
  | IncludeParseError ParseError
  | IncludeCycle [Located FilePath]
    deriving (Int -> IncludeError -> ShowS
[IncludeError] -> ShowS
IncludeError -> FilePath
(Int -> IncludeError -> ShowS)
-> (IncludeError -> FilePath)
-> ([IncludeError] -> ShowS)
-> Show IncludeError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncludeError -> ShowS
showsPrec :: Int -> IncludeError -> ShowS
$cshow :: IncludeError -> FilePath
show :: IncludeError -> FilePath
$cshowList :: [IncludeError] -> ShowS
showList :: [IncludeError] -> ShowS
Show, (forall x. IncludeError -> Rep IncludeError x)
-> (forall x. Rep IncludeError x -> IncludeError)
-> Generic IncludeError
forall x. Rep IncludeError x -> IncludeError
forall x. IncludeError -> Rep IncludeError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IncludeError -> Rep IncludeError x
from :: forall x. IncludeError -> Rep IncludeError x
$cto :: forall x. Rep IncludeError x -> IncludeError
to :: forall x. Rep IncludeError x -> IncludeError
Generic, IncludeError -> ()
(IncludeError -> ()) -> NFData IncludeError
forall a. (a -> ()) -> NFData a
$crnf :: IncludeError -> ()
rnf :: IncludeError -> ()
NFData)

ppIncludeError :: IncludeError -> Doc
ppIncludeError :: IncludeError -> Doc
ppIncludeError IncludeError
ie = case IncludeError
ie of

  IncludeFailed Located FilePath
lp -> (Char -> Doc
char Char
'`' Doc -> Doc -> Doc
<.> FilePath -> Doc
text (Located FilePath -> FilePath
forall a. Located a -> a
thing Located FilePath
lp) Doc -> Doc -> Doc
<.> Char -> Doc
char Char
'`')
                  Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"included at"
                  Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located FilePath -> Range
forall a. Located a -> Range
srcRange Located FilePath
lp)
                  Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"was not found"

  IncludeDecodeFailed Located FilePath
lp UnicodeException
err -> (Char -> Doc
char Char
'`' Doc -> Doc -> Doc
<.> FilePath -> Doc
text (Located FilePath -> FilePath
forall a. Located a -> a
thing Located FilePath
lp) Doc -> Doc -> Doc
<.> Char -> Doc
char Char
'`')
                            Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"included at"
                            Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located FilePath -> Range
forall a. Located a -> Range
srcRange Located FilePath
lp)
                            Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"contains invalid UTF-8."
                            Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"Details:"
                            Doc -> Doc -> Doc
$$  Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat ((FilePath -> Doc) -> [FilePath] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Doc
text (FilePath -> [FilePath]
lines (UnicodeException -> FilePath
forall e. Exception e => e -> FilePath
X.displayException UnicodeException
err))))

  IncludeParseError ParseError
pe -> ParseError -> Doc
ppError ParseError
pe

  IncludeCycle [Located FilePath]
is -> FilePath -> Doc
text FilePath
"includes form a cycle:"
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat ((Located FilePath -> Doc) -> [Located FilePath] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Range -> Doc
forall a. PP a => a -> Doc
pp (Range -> Doc)
-> (Located FilePath -> Range) -> Located FilePath -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located FilePath -> Range
forall a. Located a -> Range
srcRange) [Located FilePath]
is))


newtype NoIncM a = M
  { forall a.
NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
unM :: ReaderT Env
         ( ExceptionT [IncludeError]
         ( StateT Deps
           IO
         )) a }

type Deps = Map FilePath Fingerprint

data Env = Env { Env -> [Located FilePath]
envSeen       :: [Located FilePath]
                 -- ^ Files that have been loaded

               , Env -> FilePath
envIncPath    :: FilePath
                 -- ^ The path that includes are relative to

               , Env -> FilePath -> IO ByteString
envFileReader :: FilePath -> IO ByteString
                 -- ^ How to load files
               }


runNoIncM ::
  (FilePath -> IO ByteString) ->
  FilePath ->
  NoIncM a -> IO (Either [IncludeError] (a,Deps))
runNoIncM :: forall a.
(FilePath -> IO ByteString)
-> FilePath -> NoIncM a -> IO (Either [IncludeError] (a, Deps))
runNoIncM FilePath -> IO ByteString
reader FilePath
sourcePath NoIncM a
m =
  do FilePath
incPath <- FilePath -> IO FilePath
getIncPath FilePath
sourcePath
     (Either [IncludeError] a
mb,Deps
s) <- ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> Env -> Deps -> IO (Either [IncludeError] a, Deps)
forall (m :: * -> *) a r. RunM m a r => m a -> r
runM (NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
unM NoIncM a
m)
                  Env { envSeen :: [Located FilePath]
envSeen = []
                      , envIncPath :: FilePath
envIncPath = FilePath
incPath
                      , envFileReader :: FilePath -> IO ByteString
envFileReader = FilePath -> IO ByteString
reader
                      }
                  Deps
forall k a. Map k a
Map.empty
     Either [IncludeError] (a, Deps)
-> IO (Either [IncludeError] (a, Deps))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
       do a
ok <- Either [IncludeError] a
mb
          (a, Deps) -> Either [IncludeError] (a, Deps)
forall a. a -> Either [IncludeError] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ok,Deps
s)

tryNoIncM :: NoIncM a -> NoIncM (Either [IncludeError] a)
tryNoIncM :: forall a. NoIncM a -> NoIncM (Either [IncludeError] a)
tryNoIncM NoIncM a
m = ReaderT
  Env
  (ExceptionT [IncludeError] (StateT Deps IO))
  (Either [IncludeError] a)
-> NoIncM (Either [IncludeError] a)
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M (ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> ReaderT
     Env
     (ExceptionT [IncludeError] (StateT Deps IO))
     (Either [IncludeError] a)
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> ReaderT
     Env
     (ExceptionT [IncludeError] (StateT Deps IO))
     (Either [IncludeError] a)
forall (m :: * -> *) i a.
RunExceptionM m i =>
m a -> m (Either i a)
try (NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
unM NoIncM a
m))

-- | Get the absolute directory name of a file that contains cryptol source.
getIncPath :: FilePath -> IO FilePath
getIncPath :: FilePath -> IO FilePath
getIncPath FilePath
file = FilePath -> IO FilePath
makeAbsolute (ShowS
takeDirectory FilePath
file)

-- | Run a 'NoIncM' action with a different include path.  The argument is
-- expected to be the path of a file that contains cryptol source, and will be
-- adjusted with getIncPath.
withIncPath :: FilePath -> NoIncM a -> NoIncM a
withIncPath :: forall a. FilePath -> NoIncM a -> NoIncM a
withIncPath FilePath
path (M ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
body) = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M (ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
 -> NoIncM a)
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a b. (a -> b) -> a -> b
$
  do FilePath
incPath <- IO FilePath
-> ReaderT
     Env (ExceptionT [IncludeError] (StateT Deps IO)) FilePath
forall a.
IO a -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) (n :: * -> *) a. BaseM m n => n a -> m a
inBase (FilePath -> IO FilePath
getIncPath FilePath
path)
     Env
env     <- ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Env
forall (m :: * -> *) i. ReaderM m i => m i
ask
     Env
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
Env
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) i a. RunReaderM m i => i -> m a -> m a
local Env
env { envIncPath = incPath } ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
body

-- | Adjust an included file with the current include path.
fromIncPath :: FilePath -> NoIncM FilePath
fromIncPath :: FilePath -> NoIncM FilePath
fromIncPath FilePath
path
  | FilePath -> Bool
isAbsolute FilePath
path = FilePath -> NoIncM FilePath
forall a. a -> NoIncM a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
  | Bool
otherwise       = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) FilePath
-> NoIncM FilePath
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M
    do Env { FilePath
[Located FilePath]
FilePath -> IO ByteString
envSeen :: Env -> [Located FilePath]
envIncPath :: Env -> FilePath
envFileReader :: Env -> FilePath -> IO ByteString
envSeen :: [Located FilePath]
envIncPath :: FilePath
envFileReader :: FilePath -> IO ByteString
.. } <- ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Env
forall (m :: * -> *) i. ReaderM m i => m i
ask
       FilePath
-> ReaderT
     Env (ExceptionT [IncludeError] (StateT Deps IO)) FilePath
forall a.
a -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
envIncPath FilePath -> ShowS
</> FilePath
path)

addDep :: FilePath -> Fingerprint -> NoIncM ()
addDep :: FilePath -> Fingerprint -> NoIncM ()
addDep FilePath
path Fingerprint
fp = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
-> NoIncM ()
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M
  do Deps
s <- ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Deps
forall (m :: * -> *) i. StateM m i => m i
get
     let s1 :: Deps
s1 = FilePath -> Fingerprint -> Deps -> Deps
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
path Fingerprint
fp Deps
s
     Deps
s1 Deps
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
forall a b. a -> b -> b
`seq` Deps -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set Deps
s1


instance Functor NoIncM where
  fmap :: forall a b. (a -> b) -> NoIncM a -> NoIncM b
fmap = (a -> b) -> NoIncM a -> NoIncM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance A.Applicative NoIncM where
  pure :: forall a. a -> NoIncM a
pure a
x = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M (a -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
a -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  <*> :: forall a b. NoIncM (a -> b) -> NoIncM a -> NoIncM b
(<*>) = NoIncM (a -> b) -> NoIncM a -> NoIncM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad NoIncM where
  return :: forall a. a -> NoIncM a
return   = a -> NoIncM a
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  NoIncM a
m >>= :: forall a b. NoIncM a -> (a -> NoIncM b) -> NoIncM b
>>= a -> NoIncM b
f  = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b
-> NoIncM b
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M (NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
unM NoIncM a
m ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> (a
    -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b)
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b
forall a b.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> (a
    -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b)
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NoIncM b
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b
forall a.
NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
unM (NoIncM b
 -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b)
-> (a -> NoIncM b)
-> a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NoIncM b
f)

instance Fail.MonadFail NoIncM where
  fail :: forall a. FilePath -> NoIncM a
fail FilePath
x = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M (FilePath
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
FilePath
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
x)

-- | Raise an 'IncludeFailed' error.
includeFailed :: Located FilePath -> NoIncM a
includeFailed :: forall a. Located FilePath -> NoIncM a
includeFailed Located FilePath
path = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M ([IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
[IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise [Located FilePath -> IncludeError
IncludeFailed Located FilePath
path])

-- | Push a path on the stack of included files, and run an action.  If the path
-- is already on the stack, an include cycle has happened, and an error is
-- raised.
pushPath :: Located FilePath -> NoIncM a -> NoIncM a
pushPath :: forall a. Located FilePath -> NoIncM a -> NoIncM a
pushPath Located FilePath
path NoIncM a
m = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M (ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
 -> NoIncM a)
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a b. (a -> b) -> a -> b
$ do
  Env { FilePath
[Located FilePath]
FilePath -> IO ByteString
envSeen :: Env -> [Located FilePath]
envIncPath :: Env -> FilePath
envFileReader :: Env -> FilePath -> IO ByteString
envSeen :: [Located FilePath]
envIncPath :: FilePath
envFileReader :: FilePath -> IO ByteString
.. } <- ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Env
forall (m :: * -> *) i. ReaderM m i => m i
ask
  let alreadyIncluded :: Located FilePath -> Bool
alreadyIncluded Located FilePath
l = Located FilePath -> FilePath
forall a. Located a -> a
thing Located FilePath
path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Located FilePath -> FilePath
forall a. Located a -> a
thing Located FilePath
l
  Bool
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Located FilePath -> Bool) -> [Located FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Located FilePath -> Bool
alreadyIncluded [Located FilePath]
envSeen) ([IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
forall a.
[IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise [[Located FilePath] -> IncludeError
IncludeCycle [Located FilePath]
envSeen])
  Env
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
Env
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) i a. RunReaderM m i => i -> m a -> m a
local Env { envSeen :: [Located FilePath]
envSeen = Located FilePath
pathLocated FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:[Located FilePath]
envSeen, FilePath
FilePath -> IO ByteString
envIncPath :: FilePath
envFileReader :: FilePath -> IO ByteString
envIncPath :: FilePath
envFileReader :: FilePath -> IO ByteString
.. } (NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
unM NoIncM a
m)

-- | Lift an IO operation, with a way to handle the exception that it might
-- throw.
failsWith :: X.Exception e => IO a -> (e -> NoIncM a) -> NoIncM a
failsWith :: forall e a. Exception e => IO a -> (e -> NoIncM a) -> NoIncM a
failsWith IO a
m e -> NoIncM a
k = ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M (ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
 -> NoIncM a)
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
forall a b. (a -> b) -> a -> b
$ do
  Either e a
e <- IO (Either e a)
-> ReaderT
     Env (ExceptionT [IncludeError] (StateT Deps IO)) (Either e a)
forall a.
IO a -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) (n :: * -> *) a. BaseM m n => n a -> m a
inBase (IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
X.try IO a
m)
  case Either e a
e of
    Right a
a  -> a -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
a -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left e
exn -> NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall a.
NoIncM a
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
unM (e -> NoIncM a
k e
exn)

-- | Like 'mapM', but tries to collect as many errors as possible before
-- failing.
collectErrors :: (a -> NoIncM b) -> [a] -> NoIncM [b]
collectErrors :: forall a b. (a -> NoIncM b) -> [a] -> NoIncM [b]
collectErrors a -> NoIncM b
f [a]
ts = do
  [Either [IncludeError] b]
es <- (a -> NoIncM (Either [IncludeError] b))
-> [a] -> NoIncM [Either [IncludeError] b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (NoIncM b -> NoIncM (Either [IncludeError] b)
forall a. NoIncM a -> NoIncM (Either [IncludeError] a)
tryNoIncM (NoIncM b -> NoIncM (Either [IncludeError] b))
-> (a -> NoIncM b) -> a -> NoIncM (Either [IncludeError] b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NoIncM b
f) [a]
ts
  let ([[IncludeError]]
ls,[b]
rs) = [Either [IncludeError] b] -> ([[IncludeError]], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either [IncludeError] b]
es
      errs :: [IncludeError]
errs    = [[IncludeError]] -> [IncludeError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[IncludeError]]
ls
  Bool -> NoIncM () -> NoIncM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([IncludeError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IncludeError]
errs) (ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
-> NoIncM ()
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M ([IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) ()
forall a.
[IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise [IncludeError]
errs))
  [b] -> NoIncM [b]
forall a. a -> NoIncM a
forall (m :: * -> *) a. Monad m => a -> m a
return [b]
rs

-- | Remove includes from a module.
noIncludeModule :: ModuleG mname PName -> NoIncM (ModuleG mname PName)
noIncludeModule :: forall mname. ModuleG mname PName -> NoIncM (ModuleG mname PName)
noIncludeModule ModuleG mname PName
m =
  do ModuleDefinition PName
newDef <- case ModuleG mname PName -> ModuleDefinition PName
forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG mname PName
m of
                 NormalModule [TopDecl PName]
ds         -> [TopDecl PName] -> ModuleDefinition PName
forall name. [TopDecl name] -> ModuleDefinition name
NormalModule ([TopDecl PName] -> ModuleDefinition PName)
-> NoIncM [TopDecl PName] -> NoIncM (ModuleDefinition PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TopDecl PName] -> NoIncM [TopDecl PName]
doDecls [TopDecl PName]
ds
                 FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
is -> ModuleDefinition PName -> NoIncM (ModuleDefinition PName)
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (ImpName PName)
-> ModuleInstanceArgs PName
-> ModuleInstance PName
-> ModuleDefinition PName
forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
is)
                 InterfaceModule Signature PName
s       -> ModuleDefinition PName -> NoIncM (ModuleDefinition PName)
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Signature PName -> ModuleDefinition PName
forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
s)
     ModuleG mname PName -> NoIncM (ModuleG mname PName)
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleG mname PName
m { mDef = newDef }
  where
  doDecls :: [TopDecl PName] -> NoIncM [TopDecl PName]
doDecls    = ([[TopDecl PName]] -> [TopDecl PName])
-> NoIncM [[TopDecl PName]] -> NoIncM [TopDecl PName]
forall a b. (a -> b) -> NoIncM a -> NoIncM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[TopDecl PName]] -> [TopDecl PName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NoIncM [[TopDecl PName]] -> NoIncM [TopDecl PName])
-> ([TopDecl PName] -> NoIncM [[TopDecl PName]])
-> [TopDecl PName]
-> NoIncM [TopDecl PName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TopDecl PName -> NoIncM [TopDecl PName])
-> [TopDecl PName] -> NoIncM [[TopDecl PName]]
forall a b. (a -> NoIncM b) -> [a] -> NoIncM [b]
collectErrors TopDecl PName -> NoIncM [TopDecl PName]
noIncTopDecl

-- | Remove includes from a program.
noIncludeProgram :: Program PName -> NoIncM (Program PName)
noIncludeProgram :: Program PName -> NoIncM (Program PName)
noIncludeProgram (Program [TopDecl PName]
tds) =
  ([TopDecl PName] -> Program PName
forall name. [TopDecl name] -> Program name
Program ([TopDecl PName] -> Program PName)
-> ([[TopDecl PName]] -> [TopDecl PName])
-> [[TopDecl PName]]
-> Program PName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TopDecl PName]] -> [TopDecl PName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ([[TopDecl PName]] -> Program PName)
-> NoIncM [[TopDecl PName]] -> NoIncM (Program PName)
forall a b. (a -> b) -> NoIncM a -> NoIncM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TopDecl PName -> NoIncM [TopDecl PName])
-> [TopDecl PName] -> NoIncM [[TopDecl PName]]
forall a b. (a -> NoIncM b) -> [a] -> NoIncM [b]
collectErrors TopDecl PName -> NoIncM [TopDecl PName]
noIncTopDecl [TopDecl PName]
tds

-- | Substitute top-level includes with the declarations from the files they
-- reference.
noIncTopDecl :: TopDecl PName -> NoIncM [TopDecl PName]
noIncTopDecl :: TopDecl PName -> NoIncM [TopDecl PName]
noIncTopDecl TopDecl PName
td = case TopDecl PName
td of
  Decl TopLevel (Decl PName)
_     -> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]
  DPrimType {} -> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]
  TDNewtype TopLevel (Newtype PName)
_-> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]
  TDEnum TopLevel (EnumDecl PName)
_-> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]
  DParamDecl {} -> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]
  DInterfaceConstraint {} -> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]
  Include Located FilePath
lf -> Located FilePath -> NoIncM [TopDecl PName]
resolveInclude Located FilePath
lf
  DModule TopLevel (NestedModule PName)
tl ->
    case TopLevel (NestedModule PName) -> NestedModule PName
forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
tl of
      NestedModule ModuleG PName PName
m ->
        do ModuleG PName PName
m1 <- ModuleG PName PName -> NoIncM (ModuleG PName PName)
forall mname. ModuleG mname PName -> NoIncM (ModuleG mname PName)
noIncludeModule ModuleG PName PName
m
           [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TopLevel (NestedModule PName) -> TopDecl PName
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule PName)
tl { tlValue = NestedModule m1 } ]
  DImport {} -> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]
  DModParam {} -> [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TopDecl PName
td]

-- | Resolve the file referenced by a include into a list of top-level
-- declarations.
resolveInclude :: Located FilePath -> NoIncM [TopDecl PName]
resolveInclude :: Located FilePath -> NoIncM [TopDecl PName]
resolveInclude Located FilePath
lf = Located FilePath
-> NoIncM [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. Located FilePath -> NoIncM a -> NoIncM a
pushPath Located FilePath
lf (NoIncM [TopDecl PName] -> NoIncM [TopDecl PName])
-> NoIncM [TopDecl PName] -> NoIncM [TopDecl PName]
forall a b. (a -> b) -> a -> b
$ do
  Text
source <- Located FilePath -> NoIncM Text
readInclude Located FilePath
lf
  let cfg :: Config
cfg = Config
defaultConfig { cfgSource = thing lf
                          , cfgPreProc = guessPreProc (thing lf)
                          }
  case Config -> Text -> Either ParseError (Program PName)
parseProgramWith Config
cfg Text
source of

    Right Program PName
prog -> do
      Program [TopDecl PName]
ds <-
        do FilePath
path <- FilePath -> NoIncM FilePath
fromIncPath (Located FilePath -> FilePath
forall a. Located a -> a
thing Located FilePath
lf)
           FilePath -> NoIncM (Program PName) -> NoIncM (Program PName)
forall a. FilePath -> NoIncM a -> NoIncM a
withIncPath FilePath
path (Program PName -> NoIncM (Program PName)
noIncludeProgram Program PName
prog)
      [TopDecl PName] -> NoIncM [TopDecl PName]
forall a. a -> NoIncM a
forall (m :: * -> *) a. Monad m => a -> m a
return [TopDecl PName]
ds

    Left ParseError
err -> ReaderT
  Env (ExceptionT [IncludeError] (StateT Deps IO)) [TopDecl PName]
-> NoIncM [TopDecl PName]
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M ([IncludeError]
-> ReaderT
     Env (ExceptionT [IncludeError] (StateT Deps IO)) [TopDecl PName]
forall a.
[IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise [ParseError -> IncludeError
IncludeParseError ParseError
err])

-- | Read a file referenced by an include.
readInclude :: Located FilePath -> NoIncM Text
readInclude :: Located FilePath -> NoIncM Text
readInclude Located FilePath
path = do
  FilePath -> IO ByteString
readBytes   <- Env -> FilePath -> IO ByteString
envFileReader (Env -> FilePath -> IO ByteString)
-> NoIncM Env -> NoIncM (FilePath -> IO ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Env
-> NoIncM Env
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Env
forall (m :: * -> *) i. ReaderM m i => m i
ask
  FilePath
file        <- FilePath -> NoIncM FilePath
fromIncPath (Located FilePath -> FilePath
forall a. Located a -> a
thing Located FilePath
path)
  ByteString
sourceBytes <- FilePath -> IO ByteString
readBytes FilePath
file IO ByteString
-> (IOException -> NoIncM ByteString) -> NoIncM ByteString
forall e a. Exception e => IO a -> (e -> NoIncM a) -> NoIncM a
`failsWith` IOException -> NoIncM ByteString
forall a. IOException -> NoIncM a
handler
  Either UnicodeException Text
sourceText  <- Either UnicodeException Text -> IO (Either UnicodeException Text)
forall a. a -> IO a
X.evaluate (ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
sourceBytes) IO (Either UnicodeException Text)
-> (IOException -> NoIncM (Either UnicodeException Text))
-> NoIncM (Either UnicodeException Text)
forall e a. Exception e => IO a -> (e -> NoIncM a) -> NoIncM a
`failsWith` IOException -> NoIncM (Either UnicodeException Text)
forall a. IOException -> NoIncM a
handler
  case Either UnicodeException Text
sourceText of
    Left UnicodeException
encodingErr -> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Text
-> NoIncM Text
forall a.
ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
-> NoIncM a
M ([IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) Text
forall a.
[IncludeError]
-> ReaderT Env (ExceptionT [IncludeError] (StateT Deps IO)) a
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise [Located FilePath -> UnicodeException -> IncludeError
IncludeDecodeFailed Located FilePath
path UnicodeException
encodingErr])
    Right Text
txt -> do
      FilePath -> Fingerprint -> NoIncM ()
addDep FilePath
file (ByteString -> Fingerprint
fingerprint ByteString
sourceBytes)
      Text -> NoIncM Text
forall a. a -> NoIncM a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
txt
  where
  handler :: X.IOException -> NoIncM a
  handler :: forall a. IOException -> NoIncM a
handler IOException
_ = Located FilePath -> NoIncM a
forall a. Located FilePath -> NoIncM a
includeFailed Located FilePath
path