Guest User

Untitled

a guest
Nov 20th, 2017
98
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.19 KB | None | 0 0
  1. #!/usr/bin/env stack
  2. {- stack --install-ghc runghc --package aeson --package hspec -}
  3. {-# LANGUAGE ExistentialQuantification #-}
  4. {-# LANGUAGE OverloadedStrings #-}
  5.  
  6. import Control.Applicative
  7. import Data.Aeson
  8. import Test.Hspec
  9.  
  10. -- Rocket.hs library file
  11. class SomeRocket a where
  12. launchRocket :: a -> IO ()
  13.  
  14. -- Rocket/A.hs library file
  15. data A = A Int deriving (Eq, Show)
  16. instance SomeRocket A where launchRocket (A n) = putStrLn "Launch Rocket type A!"
  17.  
  18. -- Rocket/B.hs library file
  19. data B = B String deriving (Eq, Show)
  20. instance SomeRocket B where launchRocket (B s) = putStrLn "Launch Rocket type B!"
  21.  
  22. -- Rocket/C.hs library file
  23. data C = C Int String deriving (Eq, Show)
  24. instance SomeRocket C where launchRocket (C n s) = putStrLn "Launch Rocket type C!"
  25.  
  26. -- RocketConfig.hs library file
  27.  
  28. -- need some "box type" to put potentially any kind of rocket into a config.
  29. -- I would like to avoid explicitly listing them here. I would like to tell
  30. -- that this type wraps any instance of `SomeRocket`.
  31. data JsonRocketItem = ARocket A | BRocket B | CRocket C deriving (Eq, Show)
  32. -- This type acts as a wrapper that can store all rocket types,
  33. -- but still acts polymorphic as i just want to launch the rockets on them
  34. -- without knowing which actual rocket such a variable currently holds.
  35. -- They also need to derive from `Eq` because the unit tests need to
  36. -- compare them. And `Show` is also necessary because the test lib likes
  37. -- to print them in case of any mismatch.
  38.  
  39. -- this is the full blown config with all kind of rocketry configuration that
  40. -- i use in the app later.
  41. data SomeJsonObject = SomeJsonObject {
  42. blaName :: String,
  43. blaId :: Int,
  44. -- ...
  45. -- ... and an actual rocket. Do not want to know which exact kind.
  46. blaABC :: JsonRocketItem
  47. }
  48.  
  49. -- How can i get rid of the following duplication?
  50. -- I tried using ExistentialQuantification but failed implementing `Eq`
  51. -- for it. Are GADTs of any help here?
  52. instance SomeRocket JsonRocketItem where
  53. launchRocket (ARocket x) = launchRocket x
  54. launchRocket (BRocket x) = launchRocket x
  55. launchRocket (CRocket x) = launchRocket x
  56.  
  57. -- of course i need to write special parsers for every rocket.
  58. instance FromJSON JsonRocketItem where
  59. parseJSON = withObject "Some JSON Item" $ \o ->
  60. ((CRocket .) . C <$> o .: "a" <*> o .: "b") <|>
  61. (ARocket . A <$> o .: "a") <|>
  62. (BRocket . B <$> o .: "b")
  63.  
  64. -- not defining the FromJSON instance `SomeJsonObject` because it's not needed
  65. -- for the example.
  66.  
  67. -- Application.hs or Test.hs
  68.  
  69. main :: IO ()
  70. main = hspec $
  71. describe "Rocket config parser" $ do
  72. it "can parse rocket type A" $
  73. decode "{\"a\" : 123}" `shouldBe` Just (ARocket $ A 123)
  74.  
  75. it "can parse rocket type B" $
  76. decode "{\"b\" : \"foo\"}" `shouldBe` Just (BRocket $ B "foo")
  77.  
  78. it "can parse rocket type C" $
  79. decode "{\"a\" : 123, \"b\" : \"foo\"}" `shouldBe` Just (CRocket $ C 123 "foo")
  80.  
  81. -- The perfect workflow i wish for when adding new types of rockets:
  82. -- 1. add a Rocket/Z.hs file where type rocket Z is implemented.
  83. -- 2. add a Rocket Z type parser to the `FromJSON` instance of `JsonRocketItem`
  84. --
  85. -- ... and nothing else. Is that possible somehow?
Add Comment
Please, Sign In to add comment