packages feed

hs-di (empty) → 0.2.0

raw patch · 14 files changed

+659/−0 lines, 14 filesdep +MissingHdep +QuickCheckdep +basesetup-changed

Dependencies added: MissingH, QuickCheck, base, compose-ltr, hs-di, hspec, template-haskell, time

Files

+ Common.hs view
@@ -0,0 +1,5 @@+module Common+  ( module Common+  ) where++import ComposeLTR as Common
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Milan Nagy (c) 2016++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 Milan Nagy 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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hs-di.cabal view
@@ -0,0 +1,73 @@+name:                hs-di+version:             0.2.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+license:             BSD3+license-file:        LICENSE+author:              Milan Nagy+maintainer:          123.wizek@gmail.com+copyright:           2016 Milan Nagy+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:      src, .+  other-modules:+    Common+  exposed-modules:+    DependencyInjector+    DI+  build-depends:+    base >= 4.7 && < 5+    , template-haskell+    , compose-ltr+  default-language:    Haskell2010++test-suite hs-di-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test, .+  other-modules:+    Common+    Gradual+    MainSpec+    SimpleDefs+    GradualSpec+    NotSoEasyToTestCode+    DefsToTestModuleSupport+    DefsToTestIdiomaticModuleSupport+  main-is:             Spec.hs+  build-depends:+    base+    , hs-di+    , hspec+    , QuickCheck+    , template-haskell+    , time+    , MissingH+    , compose-ltr+  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.+    -- -ddump-splices+    -- -ddump-to-file++    -- -fforce-recomp+  default-language:    Haskell2010+  default-extensions:+    TemplateHaskell++source-repository head+  type:     git+  location: https://github.com/Wizek/hs-di
+ src/DI.hs view
@@ -0,0 +1,5 @@+module DI+  ( module DependencyInjector+  ) where++import DependencyInjector
+ src/DependencyInjector.hs view
@@ -0,0 +1,183 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns #-}+{-# language PatternSynonyms #-}++module DependencyInjector where++import Control.Monad+import Language.Haskell.TH+import Common++assemble :: Deps -> Q Exp+assemble = convertDepsViaTuple .> return++assembleSimple :: Deps -> Q Exp+assembleSimple = convertDepsToExp .> return++convertDepsToExp :: Deps -> Exp+convertDepsToExp = id+  .> mapDepNames (mkName .> VarE)+  -- .> mapChildren reverse+  .> convertDepsToExp'++convertDepsToExp' :: DepsG Exp -> Exp+convertDepsToExp' (getDep -> (_, name,   [])) = name+convertDepsToExp' (getDep -> (_, name, x:xs)) =+  convertDepsToExp' (Dep (AppE name (convertDepsToExp' x)) xs)++data DepsG a = Dep a [DepsG a] | Rep a [DepsG a]+  deriving (Show, Eq)++type Deps = DepsG String++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)++-- 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)++override :: String -> String -> Deps -> Deps+override a b d = if d == res then error errMsg else res+  where+  res = mapDeps (overrideDep a b) d+  errMsg = a ++ " not found while trying to override: " ++ (take 200 $ show d)+  -- If you would like to be able to do what this error prevents,+  -- pelase contact the maintainer of this package.++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+++getContentOfNextLine :: Q String+getContentOfNextLine = do+  loc <- location+  -- runIO $ print loc+  line <- runIO $ do+    file <- readFile $ loc_filename loc+    let+      (start, _) = loc_start loc+      l = file $> lines $> drop (start) $> head+    return l++  return line++getContentOfNextLineLit = getContentOfNextLine $> fmap (StringL .> LitE)++parseLineToDeps :: String -> (String, String, [String], [String])+parseLineToDeps line = (name, nameD, deps, args)+  where+  ws = words line+  name = head ws+  args = takeWhile (/= "=") $ tail ws+  nameD = d name+  deps = map d args+  d n = n ++ "D"+++inj :: Q [Dec]+inj = injectableI getContentOfNextLine+injectableI getContentOfNextLine = do+  getContentOfNextLine+  >>= parseLineToDeps .> return+  >>= injDecs++injLeaf = injectableLeaf++injectableLeaf :: String -> Q [Dec]+injectableLeaf name = injDecs (name, nameD name, [], [])++injDecs (name, nameD, depsD, deps) =+  [d|+    $identD = $consDep $nameStr $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 $ VarP $ mkName $ (++ "I") $ name) =+      $(return $ VarE $ mkName $ name)+  |]+  where+    identD :: Q Pat+    identD = return $ VarP $ mkName nameD+    nameStr :: Q Exp+    nameStr = return $ (StringL .> LitE) name+    listLiteral :: Q Exp+    listLiteral = return $ ListE $ map (mkName .> VarE) depsD+    consDep :: Q Exp+    consDep = return $ ConE $ mkName "Dep"++nameD = (++ "D")+nameT = (++ "T")++r x = x .> return++convertDepsViaTuple deps | n <- getDepName deps = LetE+  [ValD (tuplePattern deps) (NormalB (VarE $ mkName $ n ++ "T")) []]+  (convertDepsToExp deps)++tuplePattern d@(getDep -> (_, n, ds)) = tuplePattern' d n ds++tuplePattern' d n [] = wrapNameFor d+tuplePattern' d n ds = TupP $ (wrapNameFor d) : map tuplePattern ds++wrapNameFor (Dep n _) = VarP $ mkName n+wrapNameFor (Rep n _) = WildP++getDepName (getDep -> (_, n, _)) = n+getDepDs   (getDep -> (_, _, ds)) = ds++getDep (Dep n ds) = (Dep, n, ds)+getDep (Rep n ds) = (Rep, n, ds)++++-- functions for injG++injG :: Q [Dec]+injG = injectableIG getContentOfNextLine+injectableIG getContentOfNextLine = do+  getContentOfNextLine+  >>= parseLineToDepsG .> return+  >>= injDecsG++-- parseLineToDepsG :: String -> (String, String, [String], [String])+parseLineToDepsG line = (name, nameI, nameD, deps, args)+  where+  ws = words line+  name = nameI $> removeIname+  nameI = head ws+  args = takeWhile (/= "=") $ tail ws+  nameD = d name+  deps = map d args+  d n = n ++ "D"++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) =+  [d|+    $identD = $consDep $nameStr $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)+  |]+  where+    identD :: Q Pat+    identD = return $ VarP $ mkName nameD+    nameStr :: Q Exp+    nameStr = name $> StringL $> LitE $> return+    listLiteral :: Q Exp+    listLiteral = return $ ListE $ map (mkName .> VarE) depsD+    consDep :: Q Exp+    consDep = return $ ConE $ mkName "Dep"
+ test/DefsToTestIdiomaticModuleSupport.hs view
@@ -0,0 +1,6 @@+module DefsToTestIdiomaticModuleSupport where++import DI++inj+testIdimoaticImport = 19
+ test/DefsToTestModuleSupport.hs view
@@ -0,0 +1,7 @@+module DefsToTestModuleSupport where++import DI++-- testImportD = Dep "testImport" []+inj+testImport = 9
+ test/Gradual.hs view
@@ -0,0 +1,15 @@+module Gradual where++import DI++injG+aI = 1++injG+bI a = 1 + a+++injG+dI b = 3 + b++c = b + 1
+ test/GradualSpec.hs view
@@ -0,0 +1,42 @@+module GradualSpec where++import Test.Hspec hiding (specify)+import qualified Test.Hspec as Hspec (specify)+import Data.List++import Language.Haskell.TH+import DI+import SimpleDefs+import NotSoEasyToTestCode++import Data.Maybe+import Data.Time+import Data.IORef+import Data.String.Utils+import Common+import Control.Exception (evaluate)+import Gradual as G++inj+aMock = 33++spec = do+  specify "dependencies" $ do+    removeIname "aI" `shouldBe` "a"+    removeIname "aasdasdI" `shouldBe` "aasdasd"+    (evaluate $ removeIname "a") `shouldThrow` anyException+    (evaluate $ removeIname "I") `shouldThrow` anyException++  specify "injG should allow for seamless introduction" $ do+    G.a `shouldBe` 1+    G.b `shouldBe` 2+    G.c `shouldBe` 3+    $( bD $> assemble ) `shouldBe` 2+    $( bD $> override "a" "aMock" $> assemble ) `shouldBe` 34+    $( dD $> override "a" "aMock" $> assemble ) `shouldBe` 37+    G.aA `shouldBe` 1++runOnlyPrefix = [""]+specify a = if (any (`isPrefixOf` a) runOnlyPrefix)+  then Hspec.specify a+  else (\_->return ())
+ test/MainSpec.hs view
@@ -0,0 +1,227 @@+module MainSpec where++import Test.Hspec hiding (specify)+import qualified Test.Hspec as Hspec (specify)+import Data.List++import Language.Haskell.TH+import DI+import SimpleDefs+import NotSoEasyToTestCode++import Data.Maybe+import Data.Time+import Data.IORef+import Data.String.Utils+import Common+import qualified GradualSpec as G ()+import Control.Exception (evaluate)++inj+testIdiomaticImportMock = 44++spec = do+  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" [Dep "b" []]) `ppsB`+      (AppE (VarE $ mkName "a") (VarE $ mkName "b"))++    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 "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" []])+++  specify "assemble" $ do++    $(assemble barD) `shouldBe` 2+++  specify "mocking" $ do++    let+      fooDMock = Dep "fooMock" []+      fooMock = 33+    $(assemble $ override "foo" "fooMock" barD) `shouldBe` 34+++  specify "type variable support" $ do++    $(assemble $ idTestD) `shouldBe` 3++    let+      idDMock = Dep "idMock" []+      idMock = (+1)+    $(assemble $ override "id" "idMock" idTestD) `shouldBe` 4+++  specify "module support" $ do+    $(assemble $ testModuleD) `shouldBe` 12++  -- specify "qualified names" $ do+  --   $(assemble $ Dep "Prelude.id" []) 1 `shouldBe` 1+  --   $(assemble $ Dep "Prelude.*" []) 2 3 `shouldBe` 6+++  specify "code that is more real-life" $ do++    let parseTime t =+          fromJust $ parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q" t+    mockConsole <- newIORef []+    cTime <- newIORef $ parseTime "2016-01-01 14:00:00"+    let+      -- $(inj)+      putStrLnMockD = Dep "putStrLnMock" []+      putStrLnMockT = putStrLnMock+      putStrLnMock a = modifyIORef mockConsole (a :)++      -- readMockConsole = readIORef mockConsole >>= fmap reverse+      readMockConsole = do+        readIORef mockConsole >>= (reverse .> return)+        -- readIORef mockConsole $> (fmap reverse)++      -- $(inj)+      getCurrentTimeMockD = Dep "getCurrentTimeMock" []+      getCurrentTimeMockT = getCurrentTimeMock+      getCurrentTimeMock = readIORef cTime++      setUpThen cont = do+        writeIORef mockConsole []+        writeIORef cTime $ parseTime "2016-01-01 14:00:00"+        timer <- $(makeTimerD+            $> override "putStrLn" "putStrLnMock"+            $> override "getCurrentTime" "getCurrentTimeMock"+            $> assemble+          )+        timer+        cont timer++    readMockConsole >>= (`shouldBe` [])++    setUpThen $ \timer -> do+      readMockConsole >>= (`shouldBe` ["2016-01-01 14:00:00 UTC"])++    setUpThen $ \timer -> do+      timer+      readMockConsole >>= (`shouldBe`+        ["2016-01-01 14:00:00 UTC", "2016-01-01 14:00:00 UTC, diff: 0s"])++    setUpThen $ \timer -> do+      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"])++    -- [x] TODO figure out a way to branch out just like with Jasmine-Given JS testing framework+    setUpThen $ \timer -> do+      writeIORef cTime $ parseTime "2016-01-01 14:00:00.00002"+      timer+      readMockConsole >>= (`shouldBe`+        [ "2016-01-01 14:00:00 UTC", "2016-01-01 14:00:00.00002 UTC, diff: 0.00002s"])++++  specify "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"])++    (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`))++    (injLeaf "asdasd" $> runQ $> fmap pprint) >>=+      (`shouldSatisfy` ("asdasdD = Dep \"asdasd\" []" `isPrefixOf`))++    return ()++  describe "idiomatic module support" $ do+    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`+        "let (a, b) = aT\n in a b"+      (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"++    -- [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+      $(assemble testIdiomaticModuleD) `shouldBe` 23+      $( testIdiomaticModuleD+        $> override "testIdimoaticImport" "testIdiomaticImportMock"+        $> assemble) `shouldBe` 48++    specify "Still support clumsy fallback" $ do+      let+        aD = Dep "a" []+        aT = a+        a = 1+      $( testIdiomaticModuleD+        $> override "testIdimoaticImport" "a"+        $> assemble) `shouldBe` 5++    specify "less clumsy, requires more imports though" $ do+      let+        aD = Dep "a" []+        a = 2+      $( testIdiomaticModuleD+        $> override "testIdimoaticImport" "a"+        $> assembleSimple) `shouldBe` 6++    specify "make sure that inj also declares a value that does not require `assemble`" $ do+      testIdiomaticModuleA `shouldBe` 23+++-- runOnlyPrefix = ["!"]+runOnlyPrefix = [""]+specify a = if (any (`isPrefixOf` a) runOnlyPrefix)+  then Hspec.specify a+  else (\_->return ())
+ test/NotSoEasyToTestCode.hs view
@@ -0,0 +1,38 @@+{-# language NoMonomorphismRestriction #-}+{-# language TemplateHaskell #-}++module NotSoEasyToTestCode where++import DI++import System.IO+import Data.IORef+import Control.Monad+import Data.Time+++injLeaf "putStrLn"+injLeaf "getCurrentTime"++inj+makeTimer putStrLn getCurrentTime = liftIO $ do+  prevTime <- newIORef Nothing+  return $ liftIO $ do+    pTime <- readIORef prevTime+    time <- getCurrentTime+    writeIORef prevTime $ Just time+    case pTime of+      Nothing -> putStrLn $ show time+      Just a  -> putStrLn $ show time ++ ", diff: " ++ (show $ diffUTCTime time a)++-- Consider importing Shelly to make this even more realistic+liftIO = id++-- Dep "makeTimer" [Dep "putStrLn" [], Dep "getCurrentTime" []]+-- a = (makeTimer, putStrLn, getCurrentTime)+-- 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))+-- makeTimer' = let (f, a, b, (g, d)) = a in f a b (g d)+
+ test/SimpleDefs.hs view
@@ -0,0 +1,25 @@+module SimpleDefs+  ( module SimpleDefs+  , module DefsToTestModuleSupport+  ) where++import DI+import DefsToTestModuleSupport+import DefsToTestIdiomaticModuleSupport++inj+foo = 1++inj+bar foo = foo + 1+++injLeaf "id"+inj+idTest id = id 1 + 2  ++inj+testModule testImport = testImport + 3++inj+testIdiomaticModule testIdimoaticImport = testIdimoaticImport + 4
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}