Import all from https://github.com/Mesabloo/nihil

.gitignore

@@ -0,0 +1,5 @@
+.stack-work/
+*~
+
+*.lock
+# This is a lib, we'd rather not commit the lock file...

LICENSE

@@ -0,0 +1,30 @@
+Copyright Ghilain Bergeron (Mesabloo) (c) 2019-2020
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Ghilain Bergeron (Mesabloo) nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

diagnose.cabal

@@ -0,0 +1,41 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           diagnose
+version:        1.0.0
+homepage:       https://github.com/mesabloo/nihil#readme
+bug-reports:    https://github.com/mesabloo/nihil/issues
+author:         Mesabloo
+maintainer:     Mesabloo
+copyright:      2020 Mesabloo
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/mesabloo/nihil
+
+library
+  exposed-modules:
+      Lib
+      Text.Diagnose
+      Text.Diagnose.Diagnostic
+      Text.Diagnose.Format
+      Text.Diagnose.Format.JSON
+      Text.Diagnose.Format.Text
+      Text.Diagnose.Position
+      Text.Diagnose.Report
+  other-modules:
+      Paths_diagnose
+  hs-source-dirs:
+      src
+  default-extensions: OverloadedStrings LambdaCase BlockArguments
+  build-depends:
+      ansi-wl-pprint
+    , base >=4.7 && <5
+    , containers
+  default-language: Haskell2010

package.yaml

@@ -0,0 +1,19 @@
+name: diagnose
+version: 1.0.0
+github: "mesabloo/nihil"
+license: BSD3
+author: "Mesabloo"
+copyright: "2020 Mesabloo"
+
+dependencies:
+- base >= 4.7 && < 5
+- ansi-wl-pprint
+- containers
+
+default-extensions:
+- OverloadedStrings
+- LambdaCase
+- BlockArguments
+
+library:
+  source-dirs: src

src/Text/Diagnose.hs

@@ -0,0 +1,11 @@
+module Text.Diagnose
+( module Text.Diagnose.Diagnostic
+, module Text.Diagnose.Report
+, module Text.Diagnose.Format
+, module Text.Diagnose.Position
+) where
+
+import Text.Diagnose.Diagnostic
+import Text.Diagnose.Report hiding (prettyReport, Files)
+import Text.Diagnose.Position
+import Text.Diagnose.Format

src/Text/Diagnose/Diagnostic.hs

@@ -0,0 +1,41 @@
+module Text.Diagnose.Diagnostic
+( Diagnostic
+, diagnostic, (<~<), (<++>)
+, printDiagnostic
+) where
+
+import Text.Diagnose.Report
+import Text.Diagnose.Format
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Text.PrettyPrint.ANSI.Leijen
+import System.IO (Handle)
+
+-- | A @'Diagnostic' s m a@ is a diagnostic whose stream is a @s a@ and whose message type is @m@.
+data Diagnostic s m a
+  = Diagnostic (Files s a) [Report m]
+
+
+-- | Creates an empty 'Diagnostic' with no files and no reports.
+diagnostic :: Diagnostic s m a
+diagnostic = Diagnostic mempty mempty
+
+-- | Appends a file along with its name to the map of files of the 'Diagnostic'.
+(<~<) :: Diagnostic s m a -> (FilePath, [s a]) -> Diagnostic s m a
+Diagnostic files reports <~< (path, content) = Diagnostic (Map.insert path content files) reports
+
+-- | Appends a report to the list of reports of the 'Diagnostic'.
+(<++>) :: Diagnostic s m a -> Report m -> Diagnostic s m a
+Diagnostic files reports <++> report = Diagnostic files (reports ++ [report])
+
+infixl 5 <++>
+infixl 4 <~<
+
+
+instance (Foldable s, PrettyText (s a), PrettyText m) => PrettyText (Diagnostic s m a) where
+  prettyText (Diagnostic files reports) = indent 1 (sep (fmap (prettyReport files) reports)) <> line
+
+
+-- | Prints a @'Diagnostic' s m a@ To the given @'Handle'@
+printDiagnostic :: (Foldable s, PrettyText (s a), PrettyText m) => Handle -> Diagnostic s m a -> IO ()
+printDiagnostic handle diag = displayIO handle (renderPretty 0.9 80 $ prettyText diag)

src/Text/Diagnose/Format.hs

@@ -0,0 +1,7 @@
+module Text.Diagnose.Format
+( module Text.Diagnose.Format.Text
+, module Text.Diagnose.Format.JSON
+) where
+
+import Text.Diagnose.Format.Text
+import Text.Diagnose.Format.JSON

src/Text/Diagnose/Format/JSON.hs

@@ -0,0 +1,7 @@
+module Text.Diagnose.Format.JSON where
+
+import Text.PrettyPrint.ANSI.Leijen
+
+class PrettyJSON a where
+  -- | Prettifies a value into a JSON representation.
+  prettyJSON :: a -> Doc

src/Text/Diagnose/Format/Text.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Text.Diagnose.Format.Text where
+
+import Text.PrettyPrint.ANSI.Leijen
+
+class PrettyText a where
+  -- | Prettifies into a simple 'Doc'.
+  prettyText :: a -> Doc
+
+instance PrettyText String where
+  prettyText = pretty
+
+instance PrettyText Integer where
+  prettyText = integer
+
+instance PrettyText Int where
+  prettyText = int
+
+instance PrettyText Char where
+  prettyText = text . (: [])

src/Text/Diagnose/Position.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Text.Diagnose.Position where
+
+import Text.PrettyPrint.ANSI.Leijen
+
+-- | Offset in a stream used to determine where to put markers.
+data Position
+  = Position
+  { beginning :: (Integer, Integer) -- ^ The beginning line and column
+  , end       :: (Integer, Integer) -- ^ The end line and column
+  , file      :: String             -- ^ The name of the file (does not need to be an absolute path)
+  }
+  deriving (Show, Eq)
+
+instance Pretty Position where
+  pretty Position{..} =
+    let (bLine, bCol) = beginning
+    in angles (text file <> colon <> integer bLine <> colon <> integer bCol)
+
+instance Ord Position where
+  p1 <= p2 =
+    let (b1Line, b1Col) = beginning p1
+        (b2Line, b2Col) = beginning p2
+    in b1Line <= b2Line && b1Col <= b2Col

src/Text/Diagnose/Report.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Text.Diagnose.Report
+( Report, Marker(..), Files, Kind, Hint
+, reportError, reportWarning
+, hint
+
+, prettyReport
+) where
+
+import Text.Diagnose.Position
+import Text.Diagnose.Format
+import Text.PrettyPrint.ANSI.Leijen
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as List
+import Prelude hiding ((<$>))
+import Data.Functor ((<&>))
+import Data.Function (on)
+import Data.List (sortBy)
+import Data.Maybe (fromJust, maybeToList)
+
+type Files s a = Map FilePath [s a]
+type Markers m = Map Position (NonEmpty (Marker m))
+
+-- | A report holds a 'Kind' of report and a message along with the useful 'Marker's and 'Hint'.
+--
+--   It basically holds either an error or a warning along with additional context such as code.
+data Report m
+  = Report Kind m (Markers m) [Hint m]
+
+-- | The kind of a 'Report', either an error or a warning.
+data Kind
+  = Error
+  | Warning
+
+-- | A simple polymorphic hint holder
+data Hint m
+  = Hint m
+
+-- | A polymorphic marker, parameterized on the message type.
+--
+--   A marker is either:
+data Marker m
+  = This m   -- ^ * a "this" marker (@^^^^^ \<message\>@) used to highlight where the error/warning is located at
+  | Where m  -- ^ * a "where" marker (@----- \<message\>@) used to provide some useful information in the context
+  | Maybe m  -- ^ * a "maybe" marker (@~~~~~ \<message\>@) used to provide ideas of potential fixes
+  | Empty    -- ^ * an "empty" marker used to show a line in the error/warning without adding any sort of marker on it
+
+-- | Creates a new report.
+reportError, reportWarning :: m -> [(Position, Marker m)] -> [Hint m] -> Report m
+reportError = newReport Error
+reportWarning = newReport Warning
+
+-- | Internal creation of a new report.
+newReport :: Kind -> m -> [(Position, Marker m)] -> [Hint m] -> Report m
+newReport sev msg markers hints = Report sev msg markMap hints
+  where markMap               = foldl createMap mempty markers
+        -- | Extends a 'Map' with a marker at a given position.
+        --
+        --   If the position is already in the 'Map', the marker is simply added to the list of markers
+        --   else it is added as a non-empty list directly in the 'Map'.
+        createMap m (p, mark) = Map.insertWith (flip (<>)) p (mark List.:| []) m
+
+-- | A simple alias on the constructor of 'Hint', used to avoid exporting the constructor.
+hint :: m -> Hint m
+hint = Hint
+
+
+
+-- | Prettifies a report, when given the files it may want to used.
+prettyReport :: (Foldable s, PrettyText (s a), PrettyText m) => Files s a -> Report m -> Doc
+prettyReport files (Report kind msg markers hints) =
+  let (color, margin, sev) = prettyKind kind
+  in color (bold sev) <> colon <+> prettyText msg <$>
+     mconcat (replicate (margin - 2) space) <> text "In" <> colon <+>
+     prettyCodeWithMarkers files markers color <$> line <>
+     prettyHints hints
+
+-- | Prettifies the kind of a report.
+prettyKind :: Kind
+           -> (Doc -> Doc, Int, Doc) -- ^ Returns the color for "this" markers, the offset for the "In: <file>" part and the label of the report
+prettyKind Error   = (red, 7, brackets $ text "error")
+prettyKind Warning = (yellow, 9, brackets $ text "warning")
+
+-- | Prettifies the code along with the useful markers.
+prettyCodeWithMarkers :: (Foldable s, PrettyText m, PrettyText (s a))
+                      => Files s a    -- ^ The potential input files to use to show the code
+                      -> Markers m    -- ^ The markers to show
+                      -> (Doc -> Doc) -- ^ The color for "this" markers
+                      -> Doc
+prettyCodeWithMarkers files markers color =
+  let sortedMarkers = sortBy (compare `on` fst) (Map.toList markers)
+  in case sortedMarkers of
+    []                                   -> green (text "???")
+    (Position{beginning=begin, ..}, _):_ ->
+      let (bLine, bCol)  = begin
+          ((p, _):_)     = reverse sortedMarkers
+          maxLineMarkLen = length (show (fst (beginning p)))
+
+          showLine l     =
+            space <> text (replicate (maxLineMarkLen - length (show l)) ' ') <> integer l <> text "|"
+
+          fileContent    = fromJust (Map.lookup file files)
+
+          showMarkers    = sortedMarkers <&> uncurry \ Position{..} markers ->
+            let (bLine, bCol)  = beginning
+                (eLine, eCol)  = end
+
+                code           = fileContent !! fromIntegral (bLine - 1)
+
+                underlineLen   = fromIntegral $ (if eLine == bLine then eCol else fromIntegral (length code)) - bCol
+
+                marker m       = prettyMarker underlineLen m color magenta dullgreen
+                renderMarker m =
+                  marker m <&> \ x -> mconcat (replicate (maxLineMarkLen + 2 + fromIntegral bCol) space) <> x
+
+                renderedMarkers = List.toList markers >>= maybeToList . renderMarker
+            in white $ bold (showLine bLine) <+> prettyText code <>
+               mconcat (applyIfNotNull (line :) $ punctuate line renderedMarkers)
+      in green (text file) <$>
+         empty <$>
+         mconcat (punctuate line showMarkers)
+
+-- | Prettifies a list of 'Hint's into a single 'Doc'ument. All 'Hint's are prettified and concatenated with a 'line' in between.
+prettyHints :: (PrettyText m) => [Hint m] -> Doc
+prettyHints [] = line
+prettyHints hs = blue (fillSep $ punctuate line (fmap render hs)) <> line
+  where render (Hint msg) = smartPretty msg
+
+-- | Prettifies a marker.
+prettyMarker :: (PrettyText m)
+             => Int          -- ^ The length of the marker
+             -> Marker m     -- ^ The marker to show
+             -> (Doc -> Doc) -- ^ The color if a "this" marker
+             -> (Doc -> Doc) -- ^ The color for a "where" marker
+             -> (Doc -> Doc) -- ^ The color for a "maybe" marker
+             -> Maybe Doc    -- ^ 'Nothing' if it is the 'Empty' marker
+prettyMarker underlineLen marker colorThis colorWhere colorMaybe = case marker of
+  Empty     -> Nothing
+  This msg  -> Just (colorThis $ under '^' <+> align (smartPretty msg))
+  Where msg -> Just (colorWhere $ under '-' <+> align (smartPretty msg))
+  Maybe msg -> Just (colorMaybe $ under '~' <+> align (smartPretty msg))
+ where under   = text . replicate underlineLen
+
+-- | A smarter pretty to keep long texts in between the bounds and correctly align them.
+smartPretty :: (PrettyText d) => d -> Doc
+smartPretty = fillSep . fmap text . words . show . prettyText
+
+
+-- | Applies a function to the list if it isn't '[]', else returns it.
+applyIfNotNull :: ([a] -> [a]) -> [a] -> [a]
+applyIfNotNull _ [] = []
+applyIfNotNull f l = f l

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-16.10
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.3"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor