hs-di 0.2.2 → 0.3.0
raw patch · 10 files changed
+872/−112 lines, 10 filesdep +HUnitdep +containersdep +deepseqnew-component:exe:hs-di-casesPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, containers, deepseq, foreign-store, ghcid, haskell-src-meta, hspec-core, hspec-expectations, interpolate, interpolatedstring-perl6, neat-interpolation, regex-tdfa, text
API changes (from Hackage documentation)
Files
- README.md +117/−13
- app/Main.hs +4/−0
- hs-di.cabal +50/−3
- src/DependencyInjector.hs +175/−34
- test/Assert.hs +20/−0
- test/DefsToTestIdiomaticModuleSupport.hs +0/−0
- test/DefsToTestModuleSupport.hs +0/−1
- test/MainSpec.hs +495/−60
- test/NotSoEasyToTestCode.hs +1/−1
- test/SpecCommon.hs +10/−0
README.md view
@@ -1,4 +1,4 @@-# Haskell Dependency Injection+# Haskell Dependency Injection [](https://hackage.haskell.org/package/hs-di) A promising Dependency Injection system for Haskell. @@ -118,7 +118,7 @@ - You may be wondering what the suffix letters mean in the declarations. You don't have to concern yourself with them, it's part of the internal hidden API of the DI framework by design. - (If you are curious however, they stand for "Dependency definitions/`Defs`", "Tuple", "Assembled", and "Injectable", respectively.) + (If you are curious however, they stand for "Dependency definitions/`Deps`", "Tuple", "Assembled", and "Injectable", respectively.) - As you can see, at the end of the day, all this machinery achieves pretty much the same what a developer would do by hand: `statement (sentence noun)` The beauty, however, is that this doesn't have to be done by hand, as it would become immensly tideous and time-consuming as soon as we start to handle more than a couple dependencies. - Mocking is equally elegant: @@ -159,20 +159,22 @@ *source: https://github.com/Wizek/hs-di/blob/v0.2.1/test/NotSoEasyToTestCode.hs#L17-L26* ```haskell-writeIORef mockConsole []-writeIORef cTime $ parseTime "2016-01-01 14:00:00" timer <- $(makeTimerD $> override "putStrLn" "putStrLnMock" $> override "getCurrentTime" "getCurrentTimeMock" $> assemble ) +readMockConsole `shouldReturn` []+ writeIORef cTime $ parseTime "2016-01-01 14:00:00" timer+readMockConsole `shouldReturn` ["2016-01-01 14:00:00 UTC"]+ writeIORef cTime $ parseTime "2016-01-01 14:00:01" timer-readMockConsole >>= (`shouldBe`- [ "2016-01-01 14:00:00 UTC", "2016-01-01 14:00:01 UTC, diff: 1s"])+readMockConsole `shouldReturn`+ ["2016-01-01 14:00:00 UTC", "2016-01-01 14:00:01 UTC, diff: 1s"] ``` *excerpt from: https://github.com/Wizek/hs-di/blob/v0.2.1/test/MainSpec.hs#L95-L149*@@ -191,15 +193,117 @@ - `(-.5)` Due to limitations of Template Haskell declaration splices, "variable not in scope" errors can pop up that are annoying. Although it is in theory possible to work around these, and it is planned for a later release. - `(?)` How is performance impacted? Does GHC notice `f (g x) (g x)`? +### Inspirations++This package was initially inspired by the Dependency Injection framework of AngularJS (1.x). +Additional inspiration came when I was looking for ways to make DI work in a statically typed language at compile time, and found out about Dagger (Java).+ ### Todo checklist -- [x] make multiple arguments work-- [x] Simplify Deps-- [x] reorder arguments of override-- [x] try with some real-life code-- [x] Write quasi quoter or TH splicer that writes the `Deps` definitions too-- [x] look for a way to have full module support (without having to explicitly re-export and risk name-clashes)-- [ ] work around "variable not in scope" error by collecting all declarations in a splice at the end of the file+- [x] `v0.2+` make multiple arguments work+- [x] `v0.2+` Simplify Deps+- [x] `v0.2+` reorder arguments of override+- [x] `v0.2+` try with some real-life code+- [x] `v0.2+` Write quasi quoter or TH splicer that writes the `Deps` definitions too+- [x] `v0.2+` look for a way to have full module support (without having to explicitly re-export and risk name-clashes)+- [x] `v0.3+` Support function headers that are not immediately below+ - [ ] Consider using haskell-source-meta to extract parameter info +- [x] `v0.3+` work around "variable not in scope" error by collecting all declarations in a splice at the end of the file+- [x] `v0.3+` Allow single dependency more than once - [ ] have GHC support Dec TH splices in let bindings: https://ghc.haskell.org/trac/ghc/ticket/9880#comment:7 Which could make overriding dependencies with mocks more pleasant - [ ] have GHC lift stage restriction++### Experimental Features++#### "Inject Gradual": Gradually introduce DI+++```haskell+-- Lib.hs+{-# language TemplateHaskell #-}++module Lib where++import DI++injG+nounI = "World"++injG+sentence :: String+sentenceI noun = "Hello " ++ noun++injG+statementI sentence = sentence ++ "!"++legacyStatement = sentence ++ "..."+```++The `injG` top level `Q [Dec]` splice requires the dependency name to end with the suffix `I`, and defines an injected (assembled) value without the suffix to be used in legacy code not yet part of dependency injection. E.g. `nounI` --> `noun`. This allows for more gradual transition of a codebase into using DI, since declarations can be updated one at a time while allowing the program to remain able to be compiled and identical in terms of execution and behaviour.++```+Lib.hs:11:1-3: Splicing declarations+ injG+ ======>+ sentenceD = Dep "sentence" [nounD]+ sentenceT = (sentenceI, nounT)+ sentenceA = sentenceI nounA+ sentence = sentenceA+```++#### Inject All++```haskell+-- Lib.hs+{-# language TemplateHaskell #-}++module Lib where++import DI++injAllG++sentenceI noun = "Hello " ++ noun+nounI = "World"+statementI sentence = sentence ++ "!"+```++This allows us to overcome multiple limitations of TemplateHaskell having to do with scoping, and avoid errors such as `Lib.hs:10:1: Not in scope: ‘noun’`.+It also allows us to define our declarations in arbitrary order.++```+Lib.hs:8:1-7: Splicing declarations+ injAllG+ ======>+ sentenceD = Dep "sentence" Original Pure [nounD] :: Deps+ sentenceT = (sentenceI, nounT)+ sentenceA = sentenceI noun+ sentence = sentenceA+ nounD = Dep "noun" Original Pure [] :: Deps+ nounT = (nounI)+ nounA = nounI+ noun = nounA+ statementD = Dep "statement" Original Pure [sentenceD] :: Deps+ statementT = (statementI, sentenceT)+ statementA = statementI sentence+ statement = statementA+```++Some further reading on the subject: http://stackoverflow.com/questions/20876147/haskell-template-haskell-and-the-scope++#### Override inline++This allows us to define short and ad-hoc mocks inline++```haskell+$(assemble $ override "noun" "\"there\"" $ statementD) `shouldBe` "Hello there!"+```++Alternatively, if one uses a HereDoc such as [`interpolatedstring-perl6`](https://hackage.haskell.org/package/interpolatedstring-perl6) dealing with quotation marks can be simpler:++```haskell+$(assemble $ override "noun" [qc|"there"|] $ statementD) `shouldBe` "Hello there!"+```++
+ app/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = undefined
hs-di.cabal view
@@ -1,5 +1,5 @@ name: hs-di-version: 0.2.2+version: 0.3.0 synopsis: Dependency Injection library for Haskell description: Dependency Injection library for Haskell to allow powerful unit testing and mocking (compile-time type-checked) homepage: https://github.com/Wizek/hs-di#readme@@ -8,7 +8,7 @@ author: Milan Nagy maintainer: 123.wizek@gmail.com copyright: 2016 Milan Nagy-category: Web+category: Testing, Control, Development, Dependency Injection, Template Haskell build-type: Simple extra-source-files: README.md cabal-version: >=1.10@@ -24,15 +24,46 @@ base >= 4.7 && < 5 , template-haskell , compose-ltr+ , haskell-src-meta+ , containers default-language: Haskell2010+ -- default-extensions:+ -- TemplateHaskell+ -- QuasiQuotes + ghc-options:+ -- -fdefer-type-errors++executable hs-di-cases+ -- type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: src, ., test, app+ build-depends:+ base >= 4.7 && < 5+ , template-haskell+ , compose-ltr+ , haskell-src-meta+ , containers+ , time+ -- , hs-di+ default-language: Haskell2010+ default-extensions:+ TemplateHaskell+ QuasiQuotes+ ghc-options:+ -- -ddump-splices+ -- -ddump-to-file+ -- -fdefer-type-errors+ test-suite hs-di-test type: exitcode-stdio-1.0 hs-source-dirs: test, . other-modules: Common+ Assert Gradual MainSpec+ SpecCommon SimpleDefs GradualSpec NotSoEasyToTestCode@@ -43,23 +74,35 @@ base , hs-di , hspec+ , HUnit+ , hspec-core+ , hspec-expectations , QuickCheck , template-haskell , time , MissingH , compose-ltr+ , neat-interpolation+ , text+ , deepseq+ , haskell-src-meta+ , ghcid+ , foreign-store+ , interpolatedstring-perl6+ , interpolate+ , regex-tdfa ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0 - -- -fdefer-type-errors -- TODO: -- 'ghc-options: -fdefer-type-errors' is fine during development but is not -- appropriate for a distributed package. Alternatively, if you want to use this, -- make it conditional based on a Cabal configuration flag (with 'manual: True' -- and 'default: False') and enable that flag during development.+ -- -fdefer-type-errors -- -ddump-splices -- -ddump-to-file @@ -67,6 +110,10 @@ default-language: Haskell2010 default-extensions: TemplateHaskell+ QuasiQuotes+ LambdaCase+ ViewPatterns+ ScopedTypeVariables source-repository head type: git
src/DependencyInjector.hs view
@@ -2,11 +2,20 @@ {-# language ViewPatterns #-} {-# language PatternSynonyms #-} -module DependencyInjector where+module DependencyInjector (+ module DependencyInjector,+ -- module Assembler,+ ) where +-- import Assembler import Control.Monad import Language.Haskell.TH import Common+import Data.List as L+import Language.Haskell.Meta (parseExp)+import Data.Either+import System.IO.Unsafe+import qualified Data.Set as Set assemble :: Deps -> Q Exp assemble = convertDepsViaTuple .> return@@ -16,28 +25,61 @@ convertDepsToExp :: Deps -> Exp convertDepsToExp = id- .> mapDepNames (mkName .> VarE)+ .> mapDepNames (parseExp .> either errF id) -- .> mapChildren reverse .> convertDepsToExp'+ where+ errF = ("Error parsing: " ++) .> error + convertDepsToExp' :: DepsG Exp -> Exp++convertDepsToExp' d@(Dep{kind=Monadic, cs=[]}) =+ -- AppE (VarE $ mkName "unsafePerformIO") $ convertDepsToExp' d{kind=Pure}+ -- error "xxx"+ convertDepsToExp' $ depOP (VarE $ 'unsafePerformIO) [d{kind=Pure}]+ convertDepsToExp' (getDep -> (_, name, [])) = name++-- convertDepsToExp' d@(Dep{kind=Monadic}) =+-- AppE (VarE $ mkName "unsafePerformIO") $ convertDepsToExp' d{kind=Pure}+++convertDepsToExp' d@(Dep{kind=Monadic, cs=(_:_)}) =+ error "Children not yet supported in Monadic deps"+ convertDepsToExp' (getDep -> (_, name, x:xs)) =- convertDepsToExp' (Dep (AppE name (convertDepsToExp' x)) xs)+ convertDepsToExp' (depOP (AppE name (convertDepsToExp' x)) xs) -data DepsG a = Dep a [DepsG a] | Rep a [DepsG a]++data DepsG a = Dep {name :: a, src :: DepSrc, kind :: DepKind, cs :: [DepsG a]} deriving (Show, Eq) +data DepSrc = Original | Replaced+ deriving (Show, Eq)+-- [ ] TODO consider makeing `override` handle the tuple too making the+-- distinction between original and overridden dependencies obsolete++data DepKind = Pure | Monadic+ deriving (Show, Eq)+ type Deps = DepsG String+-- [ ] TODO conder redefining as+-- type Deps = DepsG Exp+-- or+-- type Deps = DepsG ExpQ +instance Ord a => Ord (DepsG a) where+ compare (getDep -> (_, n1, _)) (getDep -> (_, n2, _)) =+ compare n1 n2+ mapDepNames :: (a -> b) -> DepsG a -> DepsG b-mapDepNames f (Dep n xs) = Dep (f n) (map (mapDepNames f) xs)-mapDepNames f (Rep n xs) = Rep (f n) (map (mapDepNames f) xs)+mapDepNames f (getDep -> (c, n, xs)) = c (f n) (map (mapDepNames f) xs) -- mapDeps :: (DepsG a -> DepsG b) -> DepsG a -> DepsG b mapDeps f d | (cons, n, xs) <- getDep d = f $ cons n (map (mapDeps f) xs) -mapChildren f (Dep n xs) = Dep n (f $ map (mapChildren f) xs)+mapChildren f (getDep -> (c, n, xs)) = c n (f $ map (mapChildren f) xs) override :: String -> String -> Deps -> Deps override a b d = if d == res then error errMsg else res@@ -50,8 +92,8 @@ overrideName a b n | n == a = b | otherwise = n -overrideDep a b d | (c, n, ds) <- getDep d =- if n == a then (Rep b ds) else d+overrideDep a b d@(getDep -> (c, n, ds)) =+ if n == a then d{name=b, src=Replaced} else d getContentOfNextLine :: Q String@@ -62,11 +104,31 @@ file <- readFile $ loc_filename loc let (start, _) = loc_start loc- l = file $> lines $> drop (start) $> head+ l = file $> lines $> drop start $> head return l+ return line +getContentOfNextLines :: Q String+getContentOfNextLines = do+ loc <- location+ -- runIO $ print loc+ line <- runIO $ do+ file <- readFile $ loc_filename loc+ let+ (start, _) = loc_start loc+ l = file $> lines $> drop start $> take 10 $> unlines+ return l return line +getContentOfFile :: Q String+getContentOfFile = do+ loc <- location+ runIO $ readFile $ loc_filename loc++getContentOfFollowingFnLine :: Q String+getContentOfFollowingFnLine =+ getContentOfNextLines >>= findFirstFnDecLine .> return+ getContentOfNextLineLit = getContentOfNextLine $> fmap (StringL .> LitE) parseLineToDeps :: String -> (String, String, [String], [String])@@ -80,13 +142,16 @@ d n = n ++ "D" + inj :: Q [Dec]-inj = injectableI getContentOfNextLine-injectableI getContentOfNextLine = do- getContentOfNextLine+inj = injI getContentOfFollowingFnLine+injI getContentOfFollowingFnLine = do+ getContentOfFollowingFnLine >>= parseLineToDeps .> return >>= injDecs +injectableI = injI+ injLeaf = injectableLeaf injectableLeaf :: String -> Q [Dec]@@ -94,11 +159,11 @@ injDecs (name, nameD, depsD, deps) = [d|- $identD = $consDep $nameStr $listLiteral+ $identD = $consDep $nameStr $(nce "Original") $(nce "Pure") $listLiteral $(return $ VarP $ mkName $ nameT $ name) = $(return $ TupE $ map (VarE . mkName) (name : map (++ "T") deps)) $(return $ VarP $ mkName $ name ++ "A") =- $(return $ convertDepsToExp $ Dep name (map (mapDepNames (++ "A")) (map (flip Dep []) deps)))+ $(return $ convertDepsToExp $ depOP name (map (mapDepNames (++ "A")) (map (flip depOP []) deps))) $(return $ VarP $ mkName $ (++ "I") $ name) = $(return $ VarE $ mkName $ name) |]@@ -111,66 +176,130 @@ listLiteral = return $ ListE $ map (mkName .> VarE) depsD consDep :: Q Exp consDep = return $ ConE $ mkName "Dep"+ -- ne = return . VarE . mkName+ nce = return . ConE . mkName nameD = (++ "D") nameT = (++ "T") r x = x .> return -convertDepsViaTuple deps | n <- getDepName deps = LetE+convertDepsViaTuple deps@(name -> n) = LetE [ValD (tuplePattern deps) (NormalB (VarE $ mkName $ n ++ "T")) []] (convertDepsToExp deps) -tuplePattern d@(getDep -> (_, n, ds)) = tuplePattern' d n ds+tuplePattern d@(getDep -> (_, n, ds)) = tuplePattern' Set.empty d n ds $> fst -tuplePattern' d n [] = wrapNameFor d-tuplePattern' d n ds = TupP $ (wrapNameFor d) : map tuplePattern ds+tuplePattern' set d n [] = inSet set d $ \set -> (wrapNameFor d, set)+tuplePattern' set d n ds = inSet set d $ \set ->+ let+ (ds', set') = foldr f ([], set) ds+ -- f (getDep -> (_, n, ds)) (ls, set) = isSet set n $ \set -> ()+ f d@(getDep -> (_, n, ds)) (ls, set) = let (d', set') = tuplePattern' set d n ds in (d':ls, set')+ -- inSetOrInsert n set (WildP:ls, set) $ \set -> ( set) -wrapNameFor (Dep n _) = VarP $ mkName n-wrapNameFor (Rep n _) = WildP+ in (TupP $ (wrapNameFor d) : ds', set') +inSetOrInsert a set o1 o2 =+ if a `Set.member` set+ then o1+ else o2 $ a `Set.insert` set++inSet set d x =+ if d `Set.member` set+ then (WildP, set)+ -- else x+ else x $ d `Set.insert` set++++wrapNameFor (Dep n Original _ _) = VarP $ mkName n+wrapNameFor (Dep _ Replaced _ _) = WildP+ getDepName (getDep -> (_, n, _)) = n getDepDs (getDep -> (_, _, ds)) = ds -getDep (Dep n ds) = (Dep, n, ds)-getDep (Rep n ds) = (Rep, n, ds)+getDep (Dep n s p ds) = ((\n' ds' -> Dep n' s p ds'), n, ds) -- functions for injG injG :: Q [Dec]-injG = injectableIG getContentOfNextLine-injectableIG getContentOfNextLine = do- getContentOfNextLine+injG = injIG getContentOfFollowingFnLine+injIG getContentOfFollowingFnLine = do+ getContentOfFollowingFnLine >>= parseLineToDepsG .> return- >>= injDecsG+ >>= injDecsG 'Pure +injMG :: Q [Dec]+injMG = do+ getContentOfFollowingFnLine+ >>= parseLineToDepsG .> return+ >>= injDecsG 'Monadic++injAllG :: Q [Dec]+injAllG = do+ getContentOfFile+ >>= lines+ .> groupByIndentation+ .> filter (concat .> words .> uncons .> maybe False (fst .> ("I" `isSuffixOf`)))+ .> map (unlines .> parseLineToDepsG .> injDecsG 'Pure)+ .> sequence+ .> fmap concat+ -- parseLineToDepsG :: String -> (String, String, [String], [String])-parseLineToDepsG line = (name, nameI, nameD, deps, args)+parseLineToDepsG ls = (name, nameI, nameD, deps, args) where+ line = findFirstFnDecLine ls ws = words line name = nameI $> removeIname nameI = head ws- args = takeWhile (/= "=") $ tail ws+ args = map (reverse .> takeWhile (/= '@') .> reverse) $ takeWhile (/= "=") $ tail ws nameD = d name deps = map d args d n = n ++ "D" +groupByIndentation = id+ .> groupBy (const $ (" " `isPrefixOf`))++joinIndentedLines = id+ .> groupByIndentation+ .> map (intercalate "")++findFirstFnDecLine ls = ls+ $> lines+ $> joinIndentedLines+ $> L.find (("=" `L.isInfixOf`) `andf` (("=>" `L.isInfixOf`) .> not))+ $> maybe (error $ "Couldn't find function definition:\n" ++ ls) id++orf :: (a -> Bool) -> (a -> Bool) -> a -> Bool+orf f g x = f x || g x++andf :: (a -> Bool) -> (a -> Bool) -> a -> Bool+andf f g x = f x && g x++ removeIname n = n $> reverse .> f .> reverse where f ('I':(a@(_:_))) = a f _ = error $ "Name must end with `I` suffix. e.g. `fooI` or `barI`: " ++ n -injDecsG (name, nameI, nameD, depsD, deps) =+depOP n ds = Dep n Original Pure ds++injDecsG n (name, nameI, nameD, depsD, deps) = [d|- $identD = $consDep $nameStr $listLiteral :: Deps+ $identD = $consDep $nameStr Original $(return $ ConE $ n) $listLiteral :: Deps $(return $ VarP $ mkName $ nameT $ name) = $(return $ TupE $ map (mkName .> VarE) ((name ++ "I") : map (++ "T") deps))- $(return $ VarP $ mkName $ name) =- $(return $ convertDepsToExp $ Dep nameI (map (flip Dep []) deps)) $(return $ VarP $ mkName $ name ++ "A") =- $(return $ VarE $ mkName $ name)+ -- $(assemble $ depOP nameI (map (flip depOP []) deps))+ $(return $ convertDepsToExp $ depOP nameI (map (flip depOP []) deps))+ $(return $ VarP $ mkName $ name) =+ $(if n == 'Pure+ then return $ VarE $ mkName $ name ++ "A"+ else return $ AppE (VarE 'unsafePerformIO) (VarE $ mkName $ name ++ "A")+ ) |] where identD :: Q Pat@@ -181,3 +310,15 @@ listLiteral = return $ ListE $ map (mkName .> VarE) depsD consDep :: Q Exp consDep = return $ ConE $ mkName "Dep"++injP :: Q Pat+injP = injG >>= transposeDecsToPE .> fst .> return++injE :: Q Exp+injE = injG >>= transposeDecsToPE .> snd .> return++transposeDecsToPE :: [Dec] -> (Pat, Exp)+transposeDecsToPE decs = (pats, exps)+ where+ pats = TupP $ map (\(ValD p e _) -> p) decs+ exps = TupE $ map (\(ValD p (NormalB e) _) -> e) decs
+ test/Assert.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Assert (aa) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.Meta+import ComposeLTR+import Data.String.Utils+-- import Language.Haskell.QuasiQuotes++aa :: QuasiQuoter+aa = QuasiQuoter { quoteExp = f }++f :: String -> Q Exp+f ss = [| $(n "specify") $(return $ LitE $ StringL s) $ $(parseExp s $> either error return) |]+ where+ s = strip ss++n s = return $ VarE $ mkName s
test/DefsToTestIdiomaticModuleSupport.hs view
test/DefsToTestModuleSupport.hs view
@@ -2,6 +2,5 @@ import DI --- testImportD = Dep "testImport" [] inj testImport = 9
test/MainSpec.hs view
@@ -1,7 +1,8 @@ module MainSpec where -import Test.Hspec hiding (specify)-import qualified Test.Hspec as Hspec (specify)+import Test.Hspec as Hspec hiding (specify, it)+import qualified Test.Hspec as Hspec (specify, it)+import qualified Test.Hspec.Core.Runner as HC import Data.List import Language.Haskell.TH@@ -15,49 +16,89 @@ import Data.String.Utils import Common import qualified GradualSpec as G ()-import Control.Exception (evaluate)+import Control.Exception+import NeatInterpolation+import qualified Data.Text as T+import Control.DeepSeq (force)+import Language.Haskell.Meta+import Assert+import Language.Haskell.Ghcid+import Control.Concurrent+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent.MVar+import Foreign.Store+-- import Data.IORef+import qualified Data.Text.IO as T+-- import qualified Test.HUnit as HUnit+import Test.Hspec.Expectations+import Text.InterpolatedString.Perl6+import Data.String.Interpolate.Util+import SpecCommon+import Data.Monoid+import Text.Regex.TDFA+import Test.HUnit.Lang (HUnitFailure(..)) inj testIdiomaticImportMock = 44 -spec = do- specify "mapDepNames" $ do+inj+a :: Int+a = 1 - let l x = Dep x []+injG+bI :: Int+bI = 2 - mapDepNames (const "2" ) (Dep "1" []) `shouldBe` (Dep "2" [])- mapDepNames (const 2) (Dep "1" []) `shouldBe` (Dep 2 []) +mainColor = HC.hspecWith+ HC.defaultConfig{HC.configColorMode=HC.ColorAlways}+ $ specWith setUpGhcidCached +main = hspec spec++spec = specWith setUpGhcidUncached++specWith setUpGhcid = do+ let+ dep n c = Dep n Original Pure c+ rep n c = Dep n Replaced Pure c++ specify "mapDepNames" $ do++ let l x = dep x []++ mapDepNames (const "2" ) (dep "1" []) `shouldBe` (dep "2" [])+ mapDepNames (const 2) (dep "1" []) `shouldBe` (dep 2 [])+ specify "convertDepsToExp" $ do -- let ppsB = shouldBeF pprint -- let ppsB = shouldBeF show let ppsB = shouldBe - convertDepsToExp (Dep "a" []) `ppsB` (VarE $ mkName "a")+ convertDepsToExp (dep "a" []) `ppsB` (VarE $ mkName "a") - convertDepsToExp (Dep "a" [Dep "b" []]) `ppsB`+ convertDepsToExp (dep "a" [dep "b" []]) `ppsB` (AppE (VarE $ mkName "a") (VarE $ mkName "b")) - convertDepsToExp (Dep "a" [Dep "b" [], Dep "c" []]) `ppsB`+ convertDepsToExp (dep "a" [dep "b" [], dep "c" []]) `ppsB` (AppE (AppE (VarE $ mkName "a") (VarE $ mkName "b")) (VarE $ mkName "c")) specify "override fn" $ do - override "a" "b" (Dep "a" []) `shouldBe` Rep "b" []- override "a" "c" (Dep "a" []) `shouldBe` Rep "c" []- -- override "b" "c" (Dep "a" []) `shouldBe` Dep "a" []- evaluate (override "b" "c" (Dep "a" [])) `shouldThrow` anyException+ override "a" "b" (dep "a" []) `shouldBe` rep "b" []+ override "a" "c" (dep "a" []) `shouldBe` rep "c" []+ -- override "b" "c" (dep "a" []) `shouldBe` dep "a" []+ evaluate (override "b" "c" (dep "a" [])) `shouldThrow` anyException - -- override "x" "c" (Dep "b" [Dep "a" []]) `shouldBe` (Dep "b" [Dep "a" []])- evaluate (override "x" "c" (Dep "b" [Dep "a" []])) `shouldThrow` anyException- override "b" "c" (Dep "b" [Dep "a" []]) `shouldBe` (Rep "c" [Dep "a" []])- override "a" "c" (Dep "b" [Dep "a" []]) `shouldBe` (Dep "b" [Rep "c" []])+ -- override "x" "c" (dep "b" [dep "a" []]) `shouldBe` (dep "b" [dep "a" []])+ evaluate (override "x" "c" (dep "b" [dep "a" []])) `shouldThrow` anyException+ override "b" "c" (dep "b" [dep "a" []]) `shouldBe` (rep "c" [dep "a" []])+ override "a" "c" (dep "b" [dep "a" []]) `shouldBe` (dep "b" [rep "c" []]) - override "a" "c" (Dep "b" [Dep "a" [], Dep "a" []]) `shouldBe`- (Dep "b" [Rep "c" [], Rep "c" []])+ override "a" "c" (dep "b" [dep "a" [], dep "a" []]) `shouldBe`+ (dep "b" [rep "c" [], rep "c" []]) specify "assemble" $ do@@ -68,7 +109,7 @@ specify "mocking" $ do let- fooDMock = Dep "fooMock" []+ fooDMock = dep "fooMock" [] fooMock = 33 $(assemble $ override "foo" "fooMock" barD) `shouldBe` 34 @@ -78,7 +119,7 @@ $(assemble $ idTestD) `shouldBe` 3 let- idDMock = Dep "idMock" []+ idDMock = dep "idMock" [] idMock = (+1) $(assemble $ override "id" "idMock" idTestD) `shouldBe` 4 @@ -87,8 +128,8 @@ $(assemble $ testModuleD) `shouldBe` 12 -- specify "qualified names" $ do- -- $(assemble $ Dep "Prelude.id" []) 1 `shouldBe` 1- -- $(assemble $ Dep "Prelude.*" []) 2 3 `shouldBe` 6+ -- $(assemble $ dep "Prelude.id" []) 1 `shouldBe` 1+ -- $(assemble $ dep "Prelude.*" []) 2 3 `shouldBe` 6 specify "code that is more real-life" $ do@@ -99,7 +140,7 @@ cTime <- newIORef $ parseTime "2016-01-01 14:00:00" let -- $(inj)- putStrLnMockD = Dep "putStrLnMock" []+ putStrLnMockD = dep "putStrLnMock" [] putStrLnMockT = putStrLnMock putStrLnMock a = modifyIORef mockConsole (a :) @@ -109,7 +150,7 @@ -- readIORef mockConsole $> (fmap reverse) -- $(inj)- getCurrentTimeMockD = Dep "getCurrentTimeMock" []+ getCurrentTimeMockD = dep "getCurrentTimeMock" [] getCurrentTimeMockT = getCurrentTimeMock getCurrentTimeMock = readIORef cTime @@ -149,48 +190,56 @@ - specify "automatic deps declaration" $ do- -- deps "makeTimer" $> runQ >>= (pprint .> (`shouldBe` "Dep \"makeTimer\" [putStrLnD, getCurrentTimeD]"))+ describe "automatic deps declaration" $ do+ -- deps "makeTimer" $> runQ >>= (pprint .> (`shouldBe` "dep \"makeTimer\" [putStrLnD, getCurrentTimeD]")) -- putStrLn $( (fmap show $ location) >>= ( StringL .> LitE .> return) ) -- let asd = fmap (LitE $ StringL) getContentOfNextLine- strip $(getContentOfNextLineLit) `shouldBe` "let asd foo = foo + 1"- let asd foo = foo + 1- strip $(getContentOfNextLineLit) `shouldBe` "let asd foo = foo + 2"- let asd foo = foo + 2- let- a = strip $(getContentOfNextLineLit) `shouldBe` "asd foo = foo + 2"- asd foo = foo + 2- a- -- parseLineToDeps "foo = 1" `shouldBe` Dep "foo" []-- parseLineToDeps "a = 1" `shouldBe` ("a", "aD", [], [])- parseLineToDeps "b = 1" `shouldBe` ("b", "bD", [], [])- parseLineToDeps "b a = 1" `shouldBe` ("b", "bD", ["aD"], ["a"])+ specify "" $ do+ strip $(getContentOfNextLineLit) `shouldBe` "let asd foo = foo + 1"+ let asd foo = foo + 1+ strip $(getContentOfNextLineLit) `shouldBe` "let asd foo = foo + 2"+ let asd foo = foo + 2+ let+ a = strip $(getContentOfNextLineLit) `shouldBe` "asd foo = foo + 2"+ asd foo = foo + 2+ a+ -- parseLineToDeps "foo = 1" `shouldBe` dep "foo" []+ parseLineToDeps "a = 1" `shouldBe` ("a", "aD", [], [])+ parseLineToDeps "b = 1" `shouldBe` ("b", "bD", [], [])+ parseLineToDeps "b a = 1" `shouldBe` ("b", "bD", ["aD"], ["a"]) - (injectableI (return "asd = 2") $> runQ $> fmap pprint) >>=- (`shouldSatisfy` ("asdD = Dep \"asd\" []" `isPrefixOf`))- (injectableI (return "asd a = 2") $> runQ $> fmap pprint) >>=- (`shouldSatisfy` ("asdD = Dep \"asd\" [aD]" `isPrefixOf`))+ [aa| (injectableI (return "asd = 2") $> runQ $> fmap pprint) >>=+ (`shouldSatisfy` ("asdD = Dep \"asd\" Original Pure []" `isPrefixOf`)) |] - (injLeaf "asdasd" $> runQ $> fmap pprint) >>=- (`shouldSatisfy` ("asdasdD = Dep \"asdasd\" []" `isPrefixOf`))+ [aa| (injectableI (return "asd a = 2") $> runQ $> fmap pprint) >>=+ (`shouldSatisfy` ("asdD = Dep \"asd\" Original Pure [aD]" `isPrefixOf`)) |] - return ()+ [aa| (injLeaf "asdasd" $> runQ $> fmap pprint) >>=+ (`shouldSatisfy` ("asdasdD = Dep \"asdasd\" Original Pure []" `isPrefixOf`)) |] describe "idiomatic module support" $ do+ specify "tuplePattern" $ do+ (tuplePattern (dep "a" []) $> pprint) `shouldBe` "a"+ (tuplePattern (dep "a" [dep "b" []]) $> pprint) `shouldBe` "(a, b)"+ (tuplePattern (dep "a" [dep "b" [], dep "c" []]) $> pprint) `shouldBe` "(a, b, c)"+ -- (tuplePattern (dep "a" [dep "b" [], dep "b" []]) $> pprint) `shouldBe` "(a, b, _)"+ -- (tuplePattern (dep "a" [dep "b" [], dep "b" []]) $> pprint) `shouldSatisfy`+ -- ((=~ "b") .> (== 1))+ (tuplePattern (dep "a" [dep "b" [], dep "b" []]) $> pprint $>+ (=~ "b")) `shouldBe` (1 :: Int)+ specify "utils" $ do- -- (convertDepsViaTuple (Dep "a" []) $> runQ $> fmap pprint) `shouldReturn` "let a = aT in a"- (tuplePattern (Dep "a" []) $> pprint) `shouldBe` "a"- (tuplePattern (Dep "a" [Dep "b" []]) $> pprint) `shouldBe` "(a, b)"- (convertDepsViaTuple (Dep "a" []) $> pprint) `shouldBe` "let a = aT\n in a"- (convertDepsViaTuple (Dep "a" [Dep "b" []]) $> pprint) `shouldBe`+ -- (convertDepsViaTuple (dep "a" []) $> runQ $> fmap pprint) `shouldReturn` "let a = aT in a"+ (convertDepsViaTuple (dep "a" []) $> pprint) `shouldBe` "let a = aT\n in a"+ (convertDepsViaTuple (dep "a" [dep "b" []]) $> pprint) `shouldBe` "let (a, b) = aT\n in a b"- (convertDepsViaTuple (Dep "a" [Dep "b" [Dep "d" []], Dep "c" []]) $> pprint)+ (convertDepsViaTuple (dep "a" [dep "b" [dep "d" []], dep "c" []]) $> pprint) `shouldBe` "let (a, (b, d), c) = aT\n in a (b d) c"- (convertDepsViaTuple (Rep "a" []) $> pprint) `shouldBe` "let _ = aT\n in a"- (convertDepsViaTuple (Dep "a" [Rep "b" []]) $> pprint) `shouldBe`- "let (a, _) = aT\n in a b"+ (convertDepsViaTuple (rep "a" []) $> pprint) `shouldBe` "let _ = aT\n in a" + [aa| (convertDepsViaTuple (dep "a" [rep "b" []]) $> pprint) `shouldBe`+ "let (a, _) = aT\n in a b" |]+ -- [x] TODO: warn or error if override didn't match anything -- e.g. compare before with after to check for EQ specify "the real deal" $ do@@ -201,7 +250,7 @@ specify "Still support clumsy fallback" $ do let- aD = Dep "a" []+ aD = dep "a" [] aT = a a = 1 $( testIdiomaticModuleD@@ -210,7 +259,7 @@ specify "less clumsy, requires more imports though" $ do let- aD = Dep "a" []+ aD = dep "a" [] a = 2 $( testIdiomaticModuleD $> override "testIdimoaticImport" "a"@@ -219,9 +268,395 @@ specify "make sure that inj also declares a value that does not require `assemble`" $ do testIdiomaticModuleA `shouldBe` 23 + describe "" $ do+ let f (n, _, _, _, ds) = (n, ds)+ specify "Support for type declaration be in between inj and fn decl" $ do + ([text|+ aI b = 1+ |] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])+ ("\naI b = 1" $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])+ ("\n\naI b = 1" $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])+ ([text|+ aI :: Int+ aI b = 1+ |] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])+ -- ("" $> parseLineToDepsG $> f) `shouldBe` ("", [])+ ("" $> parseLineToDepsG $> f $> force $> evaluate) `shouldThrow` anyException+ ([text|+ aI :: x => Int+ aI b = 1+ |] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])++ a `shouldBe` 1+ b `shouldBe` 2+++ [aa| ("aI = \\n -> f $ g n" $> parseLineToDepsG $> f) `shouldBe` ("a", []) |]+ [aa| ("aI = \\n -> f $ g n" $> parseLineToDepsG $> f) `shouldBe` ("a", []) |]+ [aa| ("aI = \\x -> f $ g x" $> parseLineToDepsG $> f) `shouldBe` ("a", []) |]+ [aa| ("aI = 1" $> parseLineToDepsG $> f) `shouldBe` ("a", []) |]+ [aa| ("aI b = 1" $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"]) |]+ [aa| ("aI b = \\ x -> 1" $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"]) |]+ [aa| ("aI = 1 > 1" $> parseLineToDepsG $> f) `shouldBe` ("a", []) |]++ context "support @ notation" $ do+ [aa| ("aI f@longName = 1" $> parseLineToDepsG $> f) `shouldBe` ("a", ["longName"]) |]+ -- [aa| ("aI f @ longName = 1" $> parseLineToDepsG $> f) `shouldBe` ("a", ["longName"]) |]+ -- [aa| ("aI (f@longName) = 1" $> parseLineToDepsG $> f) `shouldBe` ("a", ["longName"]) |]++ context "multiline support" $ do+ -- [aa| ([text|+ -- aI+ -- b+ -- = 1+ -- |\] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"]) |]+ it "" $ do+ ([text|+ aI+ b+ = 1+ |] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])++ it "" $ do+ ([text|+ a :: Int -> Int+ aI+ b+ = 1+ |] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])++ it "" $ do+ ([text|+ a+ :: Int+ -> Int+ aI+ b+ = 1+ |] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["b"])++ it "" $ do+ -- threadDelay 1000000+ ([text|+ a+ :: Int+ -> Int+ aI+ b@longAssName+ = 1+ |] $> T.unpack $> parseLineToDepsG $> f) `shouldBe` ("a", ["longAssName"])++ -- let loadModule' g modName = do+ -- result <- exec g $ ":load test/" ++ modName ++ ".hs"+ -- -- if result $> last $> ("Ok, modules loaded" `isPrefixOf`)+ -- if result $> any ("Ok, modules loaded" `isPrefixOf`)+ -- then map printForward result $> sequence_+ -- else error $ "\n" ++ unlines result+++ context "ghcid" $ beforeAll setUpGhcid $ do++ it "ghcid test 1" $ \g -> do+ exec g "1+2" `shouldReturn` ["3"]++ it "ghcid test 2" $ \g -> do+ -- exec g "import GhcidTest"+ -- exec g ":load test/GhcidTest.hs" >>= print+ -- exec g ":m + GhcidTest"+ loadModule' g "GhcidTest"+ exec g "xxx" `shouldReturn` ["123"]+ exec g "xxx2" `shouldReturn` ["34"]++ specify "common dependency" $ \g -> do+ -- pendingWith [qx|+ -- s+ -- d+ -- |]++ T.writeFile "test/Scenarios/CommonDependency.hs" [text|+ import DI++ aI = 1+ bI a = a + 2+ cI a = a + 4+ dI b c = b + c++ injAllG+ |]+ loadModule' g "Scenarios/CommonDependency"+ execAssert g "$(assemble dD)" (`shouldBeStr` unlines ["8"])++ -- let+ -- (_, (_, aT), _) = dT+ -- aA = aT++ specify "common dependency 2" $ \g -> do+ T.writeFile "test/Scenarios/CommonDependency2.hs" [text|+ import DI++ xI = 1+ aI x = x + 1+ bI a = a + 2+ cI a = a + 4+ dI b c = b + c++ injAllG+ |]+ loadModule' g "Scenarios/CommonDependency2"++ execAssert g "$(assemble dD)" (`shouldBeStr` unlines ["10"])++ -- failDetails "foobar" $ 1 `shouldBe` 2++ -- 1 `shouldBe` 2+ -- $> failDetails "foobar"+ -- $> failDetails "asdasd"+++ specify "injAllG" $ \g -> do+ T.writeFile "test/Scenarios/injAll.hs" [text|+ import DI++ aI = 1+ bI a = a + 2++ injAllG+ |]+ loadModule' g "Scenarios/injAll"+ execAssert g "$(assemble bD)" (`shouldBeStr` unlines ["3"])++ specify "injAllG out-of-order" $ \g -> do+ T.writeFile "test/Scenarios/injAll2.hs" [text|+ import DI++ bI a = a + 2+ aI = 1+ cI b = b + 3++ injAllG+ |]+ loadModule' g "Scenarios/injAll2"+ execAssert g "$(assemble cD)" (`shouldBeStr` unlines ["6"])++ -- it ">>= support" $ \g -> do+ -- -- exec g ":load test/IOScenario.hs" >>= print+ -- loadModule' g "IOScenario"+ -- -- (exec g "$(assemble startupTimeStringD)" $> fmap unlines) >>= putStrLn+ -- -- (exec g "startupTimeStringD" $> fmap unlines) >>= putStrLn+ -- -- (exec g "$(assemble startupTimeStringD)" $> fmap unlines)+ -- -- `shouldReturn` unlines ["123"]++ -- (exec g "$(assemble xxxD)") >>= (unlines .> putStrLn)++ -- loadModule' g "IOScenarioMain"+ -- -- exec g "xxx" >>= unlines .> putStrLn+ -- -- exec g "$(assemble xxxD)" >>= unlines .> putStrLn++ -- -- exec g "1+1+12323" >>= map printForward .> sequence_+ -- -- print 1+ -- -- 1 `shouldBe` 2+ -- -- exec g "import Asd"+ -- -- exec g ":set -XTemplateHsaskell"+ -- exec g ":load test/Asd.hs"+ -- -- exec g "import Asd"+ -- -- exec g ":t xxxD" `shouldReturn` ["123"]+ -- exec g "xxx" `shouldReturn` ["123"]+ -- exec g "xxx2" `shouldReturn` ["34"]+ -- -- return ()+ -- -- print 1++ -- TODO: Handle splices in aa+ -- [aa| $(assemble $ override "foo" "33" barD) `shouldBe` 34 |]+ specify "override with simple expressions" $ do+ $(assemble $ override "foo" "33" barD) `shouldBe` 34+ $(assemble $ override "foo" "1 + 2" barD) `shouldBe` 4++ specify "transpose [Dec] to `(TupP [Pat], TupP [Exp])`" $ do+ ("a = 1; b = 2" $> pd $> transposeDecsToPE $> fst)+ `shouldBe` ("(a, b)" $> pp)++ ("a = 1; b = 2" $> pd $> transposeDecsToPE $> snd)+ `shouldBe` ("(1, 2)" $> pe)++ -- -- [ ] TODO: Overcome GHC stage restriction:+ -- -- home/wizek/sandbox/exp-xml/exp-xml/hs-di/test/MainSpec.hs:289:18:+ -- -- GHC stage restriction:+ -- -- ‘aD’ is used in a top-level splice or annotation,+ -- -- and must be imported, not defined locally+ -- -- In the splice: $(assemble aD)++ -- specify "allow defining injectable value at non-top-level" $ do+ -- let+ -- $(injP) = $(injE)+ -- aI = 453++ -- $(assemble aD) `shouldBe` 453+++ -- specify "override a non-leaf" $ do+ -- -- pending++ -- specify "override, change deps" $ do+ -- pending++ context "unindent" $ do+ [aa| unindent (unlines [+ "a"+ ]) `shouldBe` (unlines [+ "a"+ ]) |]++ [aa| unindent (unlines [+ " a"+ ]) `shouldBe` (unlines [+ "a"+ ]) |]++ [aa| unindent (unlines [+ " a"+ , "a"+ ]) `shouldBe` (unlines [+ " a"+ , "a"+ ]) |]++ [aa| unindent (unlines [+ " a"+ , " a"+ ]) `shouldBe` (unlines [+ " a"+ , "a"+ ]) |]++loadModule' g modName = do+ result <- exec g $ ":load test/" ++ modName ++ ".hs"+ -- if result $> last $> ("Ok, modules loaded" `isPrefixOf`)+ if result $> any ("Ok, modules loaded" `isPrefixOf`)+ -- then map printForward result $> sequence_+ then return ()+ else error $ "\n" ++ unlines result+ -- runOnlyPrefix = ["!"]+-- runOnlyPrefix = ["unindent"] runOnlyPrefix = [""] specify a = if (any (`isPrefixOf` a) runOnlyPrefix) then Hspec.specify a else (\_->return ())+it a = if (any (`isPrefixOf` a) runOnlyPrefix)+ then Hspec.specify a+ else (\_->return ())++pd = parseDecs .> fromRight+pp = parsePat .> fromRight+pe = parseExp .> fromRight+fromRight (Right a) = a+++printForward = (prefix ++) .> putStrLn+prefix = " "++noop :: Monad m => m ()+noop = return ()+dont _ = noop++xcontext n _ = context n $ it "xcontext" pending+xit n _ = it n pending+xspecify n _ = specify n pending++displayLoadingInfo = id+ .> map (\case+ -- l@(Loading _ _) -> l $> show $> (prefix ++) $> putStrLn+ -- (Message{loadMessage=msg}) -> putStrLn $ unlines $ map (prefix ++) msg+ (Message{loadMessage=msg, loadSeverity=Error}) -> error $ ("\n" ++) $ unlines $ map (prefix ++) msg+ (Message{loadMessage=msg, loadSeverity=Warning}) -> error $ ("\n" ++) $ unlines $ map (prefix ++) msg+ _ -> return ()+ )+ .> sequence_+ where+ prefix = " "+++-- setUpGhcidCached = do+-- (g, ls) <- startGhci "stack ghci hs-di:exe:hs-di-cases" (Just ".") (const $ const (return ()))+-- displayLoadingInfo ls+-- return g++-- ghcid = unsafePerformIO $ newIORef Nothing+-- ghcid = unsafePerformIO $ newMVar Nothing++setUpGhcidUncached = do+ (g, ls) <- startGhci "stack ghci hs-di:exe:hs-di-cases" (Just ".") (const $ const (return ()))+ displayLoadingInfo ls+ return g++setUpGhcidCached = {-Hspec.runIO $-} do+ (lookupStore 0 $> handle) >>= \case+ Nothing -> do+ g <- setUpGhcidUncached+ (newStore g >> return ()) `catch` (\(e :: SomeException) -> print (2, e))+ -- writeIORef ghcid $ Just g+ return g+ Just s -> readStore s+ where+ handle = (`catch` f)+ f (e :: SomeException) = do+ print (1, e)+ return Nothing+ -- [x] TODO Handle:+ -- Test suite failure for package hs-di-0.2.2+ -- hs-di-test: exited with: ExitFailure (-11)+ -- Logs printed to console++shouldBeStr :: String -> String -> IO ()+actual `shouldBeStr` expected+ | actual == expected = return ()+ | otherwise = expectationFailure failMsg+ where+ failMsg =+ [qx|+ Actual: {singleLineOrIndent actual}+ Expected: {singleLineOrIndent expected}+ |]+ -- failMsg = T.unpack+ -- [text|+ -- $(T.pack expected)+ -- ${T.pack actual}+ -- |]+ -- (actual `shouldReturn` expected) `catch` (\(e :: SomeException) ->+ -- putStrLn actual+ -- )++singleLineOrIndent = f+ where+ f str@(isMultiline -> True) = "\n" <> indent 2 str+ f str = str++isMultiline = ('\n' `elem`)+indent n str =+ str+ $> lines+ $> map (replicate n ' ' ++)+ $> unlines++removeInteractive = id+ .> groupByIndentation+ .> filter (concat .> ("<interactive>:" `isPrefixOf`) .> not)+ .> concat++exec' g cmd = do+ stdoutB <- newIORef []+ stderrB <- newIORef []+ let+ f Stdout str = modifyIORef stdoutB (<> [str])+ f Stderr str = modifyIORef stderrB (<> [str])+ execStream g cmd f+ return (,) <*> readIORef stdoutB <*> readIORef stderrB++failDetails details assert = do+ assert `catch` \(HUnitFailure loc msg) -> do+ throw $ HUnitFailure loc $ msg ++ "\n" ++ details++execAssert g cmd assert = exec g cmd+ >>= (\full -> full $> removeInteractive $> unlines $> assert+ $> failDetails ("Full: " <> (full $> unlines $> singleLineOrIndent)))
test/NotSoEasyToTestCode.hs view
@@ -30,7 +30,7 @@ -- Dep "makeTimer" [Dep "putStrLn" [], Dep "getCurrentTime" []] -- a = (makeTimer, putStrLn, getCurrentTime)--- makeTimer' = let (f, a, b) = a in f a b +-- makeTimer' = let (f, a, b) = a in f a b -- Dep "makeTimer" [Dep "putStrLn" [], Dep "getCurrentTime" [], Dep "foo" [Dep "bar" []]] -- a = (makeTimer, putStrLn, getCurrentTime, (foo, bar))
+ test/SpecCommon.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module SpecCommon (module SpecCommon) where++import Common as SpecCommon+import Text.InterpolatedString.Perl6 as SpecCommon+import Language.Haskell.TH.Quote+import Data.String.Interpolate.Util++qx = QuasiQuoter{quoteExp = unindent .> quoteExp qc}