0 | module Control.App.Spec
 1 |
 2 | import System
 3 | import Control.App
 4 | import Control.App.Console
 5 | import Data.String
 6 | import Text.PrettyPrint.Prettyprinter.Doc
 7 | import Text.PrettyPrint.Prettyprinter.Render.Terminal
 8 |
 9 | data TestError : Type where
10 |   NotEq : Show x => x -> x -> TestError
11 |
12 | prettyTestError : TestError -> Doc ann
13 | prettyTestError (NotEq a b) = hsep [pretty $ show a, "!=", pretty $ show b]
14 |
15 | record SpecState where
16 |   constructor MkState
17 |   testName : List String
18 |   fails : List (List String, TestError)
19 |
20 | ||| ```
21 | ||| spec : Spec Init => App Init ()
22 | ||| spec = describe "example" $ do
23 | |||     context "arith" $ do
24 | |||         it "1+1 = 2" $ do
25 | |||             1+1 `shouldBe` 2
26 | |||         it "1*1 = 1" $ do
27 | |||             1*1 `shouldBe` 1
28 | ||| ```
29 | public export
30 | interface Has [State SpecState SpecState] e => Spec e where
31 |   describe : String -> App e () -> App e ()
32 |   context : String -> App e () -> App e ()
33 |   it : String -> App (TestError :: e) () -> App e ()
34 |
35 | push : Spec e => String -> App e ()
36 | push text = do
37 |   s <- get SpecState
38 |   put SpecState $ { testName := text :: s.testName } s
39 | pop : Spec e => App e ()
40 | pop = do
41 |   s <- get SpecState
42 |   put SpecState $ { testName := drop 1 s.testName } s
43 |
44 | export
45 | Has [State SpecState SpecState] e => Spec e where
46 |   describe text toRun = push text *> toRun *> pop
47 |   context text toRun = push text *> toRun *> pop
48 |   it text toRun = do
49 |     push $ "test: " ++ text
50 |     handle toRun
51 |       (\_ => pop)
52 |       (\err : TestError => do
53 |         s <- get SpecState
54 |         put SpecState $ { fails := (reverse s.testName, err) :: s.fails } s
55 |         pop
56 |         )
57 |
58 | export
59 | emptyState : SpecState
60 | emptyState = MkState [] []
61 |
62 | bold' : Doc AnsiStyle -> Doc AnsiStyle
63 | bold' = annotate bold
64 | color' : Color -> Doc AnsiStyle -> Doc AnsiStyle
65 | color' = annotate . color
66 |
67 | putContext : Has [PrimIO] e => Int -> List String -> App e ()
68 | putContext n (c::ctx) = do
69 |   primIO $ putDoc $ bold' $ indent n $ pretty c
70 |   putContext (n+1) ctx
71 | putContext n [] = pure ()
72 |
73 | reportFails : Has [PrimIO, Spec] e => List (List String, TestError) -> App e ()
74 | reportFails fails = do
75 |   primIO $ putDoc $ bold' $ color' Red $
76 |     pretty (length fails) <++> "tests failed"
77 |   for_ fails $ \(contexts, err) => do
78 |     putContext 0 contexts
79 |     primIO $ putDoc $ bold' $ color' Red $ prettyTestError err
80 |   primIO $ exitFailure
81 |
82 | export
83 | specFinalReport : Has [PrimIO, Spec] e => App e ()
84 | specFinalReport = do
85 |   state <- get SpecState
86 |   case state.fails of
87 |     [] => primIO $ putDoc $ bold' $ color' Green $ "all tests passed"
88 |     _ => reportFails state.fails
89 |
90 | ||| ```
91 | ||| a `shouldBe` b
92 | ||| ```
93 | export
94 | shouldBe : HasErr TestError e => Has [Show, Eq] x => x -> x -> App e ()
95 | a `shouldBe` b = if a == b
96 |   then pure ()
97 |   else throw $ NotEq a b
98 |