From 220b39cf9407c874df02d163a57bb432a56b9ad8 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 25 2020 13:00:12 +0000 Subject: ghc-call-stack-0.1.0 base --- diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..44dec11 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2016 Simon Hengel + +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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/call-stack.cabal b/call-stack.cabal new file mode 100644 index 0000000..a917cab --- /dev/null +++ b/call-stack.cabal @@ -0,0 +1,48 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: call-stack +version: 0.1.0 +synopsis: Use GHC call-stacks in a backward compatible way +category: Data +homepage: https://github.com/sol/call-stack#readme +bug-reports: https://github.com/sol/call-stack/issues +maintainer: Simon Hengel +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/sol/call-stack + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >= 4.5.0.0 && < 5 + exposed-modules: + Data.CallStack + other-modules: + Data.SrcLoc + Paths_call_stack + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >= 4.5.0.0 && < 5 + , nanospec + , call-stack + other-modules: + Data.CallStackSpec + Example + Util + default-language: Haskell2010 diff --git a/src/Data/CallStack.hs b/src/Data/CallStack.hs new file mode 100644 index 0000000..2fb9315 --- /dev/null +++ b/src/Data/CallStack.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ImplicitParams #-} + +module Data.CallStack ( + HasCallStack +, CallStack +, SrcLoc(..) +, callStack +) where + +import Data.SrcLoc + +#if MIN_VERSION_base(4,8,1) +import qualified GHC.Stack as GHC +#endif + +#if MIN_VERSION_base(4,9,0) +import GHC.Stack (HasCallStack) +#elif MIN_VERSION_base(4,8,1) +type HasCallStack = (?callStack :: GHC.CallStack) +#else +import GHC.Exts (Constraint) +type HasCallStack = (() :: Constraint) +#endif + +type CallStack = [(String, SrcLoc)] + +callStack :: HasCallStack => CallStack +#if MIN_VERSION_base(4,9,0) +callStack = drop 1 $ GHC.getCallStack GHC.callStack +#elif MIN_VERSION_base(4,8,1) +callStack = drop 2 $ GHC.getCallStack ?callStack +#else +callStack = [] +#endif diff --git a/src/Data/SrcLoc.hs b/src/Data/SrcLoc.hs new file mode 100644 index 0000000..de7c2b7 --- /dev/null +++ b/src/Data/SrcLoc.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +module Data.SrcLoc (SrcLoc(..)) where + +#if MIN_VERSION_base(4,9,0) +import GHC.Stack (SrcLoc(..)) +#elif MIN_VERSION_base(4,8,1) +import GHC.SrcLoc (SrcLoc(..)) +#else +data SrcLoc = SrcLoc { + srcLocPackage :: String +, srcLocModule :: String +, srcLocFile :: String +, srcLocStartLine :: Int +, srcLocStartCol :: Int +, srcLocEndLine :: Int +, srcLocEndCol :: Int +} deriving (Eq, Show) +#endif diff --git a/test/Data/CallStackSpec.hs b/test/Data/CallStackSpec.hs new file mode 100644 index 0000000..ea71932 --- /dev/null +++ b/test/Data/CallStackSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +module Data.CallStackSpec (spec) where + +import Test.Hspec +import Util +import Example + +spec :: Spec +spec = do + describe "callStack" $ do + it "returns the call stack" $ do + mapLocations test `shouldBe` [ +#if MIN_VERSION_base(4,8,1) + ("bar" + , SrcLoc { + srcLocPackage = "main" + , srcLocModule = "Example" + , srcLocFile = "test/Example.hs" + , srcLocStartLine = 11 + , srcLocStartCol = 7 + , srcLocEndLine = 11 + , srcLocEndCol = 10 + } + ) + , ("foo" + , SrcLoc { + srcLocPackage = "main" + , srcLocModule = "Example" + , srcLocFile = "test/Example.hs" + , srcLocStartLine = 8 + , srcLocStartCol = 8 + , srcLocEndLine = 8 + , srcLocEndCol = 11 + } + ) +#endif + ] diff --git a/test/Example.hs b/test/Example.hs new file mode 100644 index 0000000..fc0f358 --- /dev/null +++ b/test/Example.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +module Example where + +import Data.CallStack + +test :: CallStack +test = foo + +foo :: HasCallStack => CallStack +foo = bar + +bar :: HasCallStack => CallStack +bar = callStack diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..3304a7d --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,12 @@ +module Main where + +import Test.Hspec + +import qualified Data.CallStackSpec + +spec :: Spec +spec = do + describe "Data.CallStack" Data.CallStackSpec.spec + +main :: IO () +main = hspec spec diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 index 0000000..67453ae --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} +module Util (SrcLoc(..), mapLocations) where + +#if MIN_VERSION_base(4,8,1) && !MIN_VERSION_base(4,9,0) +import qualified GHC.SrcLoc as GHC +import Data.CallStack hiding (SrcLoc(..)) + +data SrcLoc = SrcLoc { + srcLocPackage :: String +, srcLocModule :: String +, srcLocFile :: String +, srcLocStartLine :: Int +, srcLocStartCol :: Int +, srcLocEndLine :: Int +, srcLocEndCol :: Int +} deriving (Eq, Show) + +mapLocations :: CallStack -> [(String, SrcLoc)] +mapLocations = map (fmap mapLocation) + where + mapLocation location = SrcLoc { + srcLocPackage = GHC.srcLocPackage location + , srcLocModule = GHC.srcLocModule location + , srcLocFile = GHC.srcLocFile location + , srcLocStartLine = GHC.srcLocStartLine location + , srcLocStartCol = GHC.srcLocStartCol location + , srcLocEndLine = GHC.srcLocEndLine location + , srcLocEndCol = GHC.srcLocEndCol location + } +#else +import Data.CallStack +mapLocations :: CallStack -> CallStack +mapLocations = id +#endif