typechecking for path depths!

This now checks if relative paths are still inside the repository, as a
general safety mechanism to stop the linter from accidentally reading
other things, as well as a nice hint for users.

1 files changed, 20 insertions, 8 deletions

diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index a6fa17e..de7d314 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -14,20 +14,26 @@ import           Control.Monad.Writer       (MonadWriter (tell), WriterT,
 import           Data.Aeson                 (ToJSON (toJSON))
 import           Data.Text                  (Text)
 
-import           Control.Monad.Trans.Reader (Reader, runReader)
+import           Control.Monad.Reader       (local)
+import           Control.Monad.Trans.Reader (Reader, asks, runReader)
+import           Control.Monad.Writer.Lazy  (lift)
 import           Data.Maybe                 (mapMaybe)
+import           GHC.Generics               (Generic)
 import           Types
-import GHC.Generics (Generic)
+
+
+-- | for now, all context we have is how "deep" in the directory tree
+-- we currently are
+type Context = Int
 
 -- | a monad to collect hints, with some context
-type LintWriter ctxt = WriterT [Lint] (Reader ctxt) ()
+type LintWriter ctxt = LintWriter' ctxt ()
+type LintWriter' ctxt res = WriterT [Lint] (Reader (Context, ctxt)) res
 
 -- wrapped to allow for manual writing of Aeson instances
 type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
 newtype LintResult ctxt = LintResult (LintResult' ctxt)
 
-data LayerContext = LayerContext ()
-  deriving (Generic, ToJSON)
 
 -- better, less confusing serialisation of an Either Hint (a, [Hint]).
 -- Note that Left hint is also serialised as a list to make the resulting
@@ -49,9 +55,9 @@ resultToLints :: LintResult a -> [Lint]
 resultToLints (LintResult res) = snd res
 
 -- | run a linter
-runLintWriter :: ctxt -> LintWriter ctxt -> LintResult ctxt
-runLintWriter c linter =  LintResult (c, lints)
-  where lints = snd $ flip runReader c $ runWriterT linter
+runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
+runLintWriter c c' linter =  LintResult (c, lints)
+  where lints = snd $ flip runReader (c',c) $ runWriterT linter
 
 -- | write a hint into the LintWriter monad
 lint :: Level -> Text -> LintWriter a
@@ -66,3 +72,9 @@ suggest = lint Suggestion
 warn = lint Warning
 forbid = lint Forbidden
 complain = lint Error
+
+askContext :: LintWriter' a a
+askContext = lift $ asks snd
+
+askFileDepth :: LintWriter' a Int
+askFileDepth = lift $ asks fst