bug (empty) → 1

raw patch · 5 files changed

+152/−0 lines, 5 filesdep +basedep +template-haskellsetup-changed

Dependencies added: base, template-haskell

Files

• LICENSE +22/−0
• Setup.hs +2/−0
• bug.cabal +47/−0
• library/Bug.hs +35/−0
• library/Bug/Formatting.hs +46/−0

@@ -0,0 +1,22 @@+Copyright (c) 2017, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.

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

@@ -0,0 +1,47 @@+name:+  bug+version:+  1+synopsis:+  Better alternatives to the "error" function+category:+  Development, Error Handling+homepage:+  https://github.com/nikita-volkov/bug+bug-reports:+  https://github.com/nikita-volkov/bug/issues+author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2017, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >= 1.10++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/bug.git++library+  hs-source-dirs:+    library+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  exposed-modules:+    Bug+  other-modules:+    Bug.Formatting+  build-depends:+    template-haskell >= 2.8 && < 3,+    base >= 4 && < 5

@@ -0,0 +1,35 @@+module Bug+where++import Prelude+import Language.Haskell.TH.Syntax+import qualified Bug.Formatting as B+++todo :: String -> Q Exp+todo message =+  do+    updatedMessage <- locationMessage <$> location+    reportWarning updatedMessage+    [|error updatedMessage|]+  where+    locationMessage location =+      B.prefixNullable (B.loc location ++ " " ++ "TODO") message++bug :: Q Exp+bug =+  do+    prefix <- locationPrefix <$> location+    [|error . B.prefixNullable prefix|]+  where+    locationPrefix location =+      showString (B.loc location) . showChar ' ' $ "Bug"++bottom :: Q Exp+bottom =+  do+    message <- locationMessage <$> location+    [|error message|]+  where+    locationMessage location =+      showString (B.loc location) . showChar ' ' $ "Bug: Bottom evaluated"

@@ -0,0 +1,46 @@+module Bug.Formatting+where++import Prelude+import Language.Haskell.TH (Loc(..))+++loc :: Loc -> String+loc (Loc filename package module_ (startLine, startColumn) (endLine, endColumn)) =+  builder ""+  where+    builder =+      showString package .+      showChar ':' .+      showString module_ .+      showChar ':' .+      position+      where+        position =+          case startLine == endLine of+            True ->+              shows startLine .+              showChar ':' .+              columns+              where+                columns =+                  if endColumn - startColumn > 1+                    then shows startColumn . showChar '-' . shows endColumn+                    else shows startColumn+            False ->+              lineAndColumn startLine startColumn .+              showChar '-' .+              lineAndColumn endLine endColumn+              where+                lineAndColumn line column =+                  showChar '(' .+                  shows line .+                  showChar ':' .+                  shows column .+                  showChar ')'++prefixNullable :: String -> String -> String+prefixNullable to what =+  if null what+    then to+    else showString to . showString ": " . showString what $ ""