toml-parser-2.0.2.0: test/HieDemoSpec.hs
{-# Language GADTs, OverloadedStrings #-}
{-|
Module : HieDemoSpec
Description : Exercise various components of FromValue on a life-sized example
Copyright : (c) Eric Mertens, 2023
License : ISC
Maintainer : emertens@gmail.com
This module demonstrates how "Toml.Schema" can handle a real-world
format as used in hie-bios. These types are copied from
<https://github.com/haskell/hie-bios/blob/master/src/HIE/Bios/Config/YAML.hs>
with slight alterations because the Other case is for YAML-specific extensibility.
This approach would work just the same when parameterized in that same way.
-}
module HieDemoSpec where
import Data.Text (Text)
import GHC.Generics ( Generic )
import QuoteStr (quoteStr)
import Test.Hspec (Spec, it, shouldBe)
import Toml (decode)
import Toml.Schema as Toml
-----------------------------------------------------------------------
-- THIS CODE DERIVED FROM CODE UNDER THE FOLLOWING LICENSE
-----------------------------------------------------------------------
-- Copyright (c) 2009, IIJ Innovation Institute Inc.
-- 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 the copyright holders nor the names of its
-- 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.
data CradleConfig = CradleConfig
{ cradle :: CradleComponent
, dependencies :: Maybe [FilePath]
} deriving (Generic, Show, Eq)
data CradleComponent
= Multi [MultiSubComponent]
| Cabal CabalConfig
| Stack StackConfig
| Direct DirectConfig
| Bios BiosConfig
| None NoneConfig
deriving (Generic, Show, Eq)
data NoneConfig = NoneConfig
deriving (Generic, Show, Eq)
data MultiSubComponent = MultiSubComponent
{ path :: FilePath
, config :: CradleConfig
} deriving (Generic, Show, Eq)
data CabalConfig = CabalConfig
{ cabalProject :: Maybe FilePath
, cabalComponents :: OneOrManyComponents CabalComponent
} deriving (Show, Eq)
data CabalComponent = CabalComponent
{ cabalPath :: FilePath
, cabalComponent :: String
, cabalComponentProject :: Maybe FilePath
} deriving (Show, Eq)
data StackConfig = StackConfig
{ stackYaml :: Maybe FilePath
, stackComponents :: OneOrManyComponents StackComponent
} deriving (Show, Eq)
data StackComponent = StackComponent
{ stackPath :: FilePath
, stackComponent :: String
, stackComponentYAML :: Maybe FilePath
} deriving (Show, Eq)
data OneOrManyComponents component
= SingleComponent String
| ManyComponents [component]
| NoComponent
deriving (Show, Eq)
data DirectConfig = DirectConfig
{ arguments :: [String]
} deriving (Generic, Show, Eq)
data BiosConfig = BiosConfig
{ callable :: Callable
, depsCallable :: Maybe Callable
, ghcPath :: Maybe FilePath
} deriving (Show, Eq)
data Callable
= Program FilePath
| Shell String
deriving (Show, Eq)
-----------------------------------------------------------------------
-- END OF DERIVED CODE
-----------------------------------------------------------------------
instance FromValue CradleConfig where
fromValue = genericFromTable
instance FromValue CradleComponent where
fromValue = parseTableFromValue $
reqAlts [
KeyCase Multi "multi",
KeyCase Cabal "cabal",
KeyCase Stack "stack",
KeyCase Direct "direct",
KeyCase Bios "bios",
KeyCase None "none"]
instance FromValue MultiSubComponent where
fromValue = genericFromTable
instance FromValue CabalConfig where
fromValue v@Toml.List'{} = CabalConfig Nothing . ManyComponents <$> fromValue v
fromValue (Toml.Table' l t) = getComponentTable CabalConfig "cabalProject" l t
fromValue _ = fail "cabal configuration expects table or array"
getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> Text -> l -> Toml.Table' l -> Matcher l a
getComponentTable con pathKey = parseTable $ con
<$> optKey pathKey
<*> pickKey [
Key "component" (fmap SingleComponent . fromValue),
Key "components" (fmap ManyComponents . fromValue),
Else (pure NoComponent)]
instance FromValue CabalComponent where
fromValue = parseTableFromValue $ CabalComponent
<$> reqKey "path"
<*> reqKey "component"
<*> optKey "cabalProject"
instance FromValue StackConfig where
fromValue v@Toml.List'{} = StackConfig Nothing . ManyComponents <$> fromValue v
fromValue (Toml.Table' l t) = getComponentTable StackConfig "stackYaml" l t
fromValue _ = fail "stack configuration expects table or array"
instance FromValue StackComponent where
fromValue = parseTableFromValue $ StackComponent
<$> reqKey "path"
<*> reqKey "component"
<*> optKey "stackYaml"
instance FromValue DirectConfig where
fromValue = genericFromTable
instance FromValue BiosConfig where
fromValue = parseTableFromValue $ BiosConfig
<$> getCallable
<*> getDepsCallable
<*> optKey "with-ghc"
where
getCallable =
reqAlts [
KeyCase Program "program",
KeyCase Shell "shell"]
getDepsCallable =
optAlts [
KeyCase Program "dependency-program",
KeyCase Shell "dependency-shell"]
data KeyCase a where
KeyCase :: FromValue b => (b -> a) -> Text -> KeyCase a
reqAlts :: [KeyCase a] -> ParseTable l a
reqAlts xs = pickKey
[Key key (fmap con . fromValue) | KeyCase con key <- xs]
optAlts :: [KeyCase a] -> ParseTable l (Maybe a)
optAlts xs = pickKey $
[Key key (fmap (Just . con) . fromValue) | KeyCase con key <- xs] ++
[Else (pure Nothing)]
instance FromValue NoneConfig where
fromValue = parseTableFromValue (pure NoneConfig)
spec :: Spec
spec =
do it "parses this project's hie.toml" $
decode [quoteStr|
dependencies = [
"src/Toml/Lexer.x",
"src/Toml/Parser.y",
]
[[cradle.cabal]]
path = "./src"
component = "toml-parser:lib:toml-parser"
[[cradle.cabal]]
path = "./test"
component = "toml-parser:test:unittests"
[[cradle.cabal]]
path = "./test-drivers/encoder"
component = "toml-test-drivers:exe:TomlEncoder"
[[cradle.cabal]]
path = "./test-drivers/decoder"
component = "toml-test-drivers:exe:TomlDecoder"
[[cradle.cabal]]
path = "./test-drivers/highlighter"
component = "toml-test-drivers:exe:TomlHighlighter"
|]
`shouldBe`
Success [] CradleConfig
{ cradle =
Cabal
CabalConfig
{ cabalProject = Nothing
, cabalComponents =
ManyComponents
[ CabalComponent
{ cabalPath = "./src"
, cabalComponent = "toml-parser:lib:toml-parser"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test"
, cabalComponent = "toml-parser:test:unittests"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test-drivers/encoder"
, cabalComponent = "toml-test-drivers:exe:TomlEncoder"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test-drivers/decoder"
, cabalComponent = "toml-test-drivers:exe:TomlDecoder"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test-drivers/highlighter"
, cabalComponent = "toml-test-drivers:exe:TomlHighlighter"
, cabalComponentProject = Nothing
}
]
}
, dependencies = Just ["src/Toml/Lexer.x" , "src/Toml/Parser.y"]
}
it "has focused error messages" $
decode [quoteStr|
[cradle.cabal]
path = "./src"
component = 42
|]
`shouldBe`
(Failure ["3:13: expected string but got integer in cradle.cabal.component"]
:: Result String CradleConfig)
it "detects unusd keys" $
decode [quoteStr|
[[cradle.multi]]
path = "./src"
[cradle.multi.config.cradle.cabal]
component = "toml-parser:lib:toml-parser"
thing1 = 10 # unused key for test case
[[cradle.multi]]
path = "./test"
[cradle.multi.config.cradle.stack]
component = "toml-parser:test:unittests"
thing2 = 20 # more unused keys for test case
thing3 = false
|]
`shouldBe`
Success
[ "5:1: unexpected key: thing1 in cradle.multi[0].config.cradle.cabal"
, "11:1: unexpected key: thing2 in cradle.multi[1].config.cradle.stack"
, "12:1: unexpected key: thing3 in cradle.multi[1].config.cradle.stack"
]
CradleConfig
{ cradle =
Multi
[ MultiSubComponent
{ path = "./src"
, config =
CradleConfig
{ cradle =
Cabal
CabalConfig
{ cabalProject = Nothing
, cabalComponents = SingleComponent "toml-parser:lib:toml-parser"
}
, dependencies = Nothing
}
}
, MultiSubComponent
{ path = "./test"
, config =
CradleConfig
{ cradle =
Stack
StackConfig
{ stackYaml = Nothing
, stackComponents = SingleComponent "toml-parser:test:unittests"
}
, dependencies = Nothing
}
}
]
, dependencies = Nothing
}
it "parses things using components" $
decode [quoteStr|
dependencies = [
"src/Toml/Lexer.x",
"src/Toml/Parser.y",
]
[cradle.cabal]
cabalProject = "cabal.project"
[[cradle.cabal.components]]
path = "./src"
component = "toml-parser:lib:toml-parser"
[[cradle.cabal.components]]
path = "./test"
component = "toml-parser:test:unittests"
[[cradle.cabal.components]]
path = "./test-drivers/encoder"
component = "toml-test-drivers:exe:TomlEncoder"
[[cradle.cabal.components]]
path = "./test-drivers/decoder"
component = "toml-test-drivers:exe:TomlDecoder"
[[cradle.cabal.components]]
path = "./test-drivers/highlighter"
component = "toml-test-drivers:exe:TomlHighlighter"
|]
`shouldBe`
Success
[]
CradleConfig
{ cradle =
Cabal
CabalConfig
{ cabalProject = Just "cabal.project"
, cabalComponents =
ManyComponents
[ CabalComponent
{ cabalPath = "./src"
, cabalComponent = "toml-parser:lib:toml-parser"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test"
, cabalComponent = "toml-parser:test:unittests"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test-drivers/encoder"
, cabalComponent = "toml-test-drivers:exe:TomlEncoder"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test-drivers/decoder"
, cabalComponent = "toml-test-drivers:exe:TomlDecoder"
, cabalComponentProject = Nothing
}
, CabalComponent
{ cabalPath = "./test-drivers/highlighter"
, cabalComponent = "toml-test-drivers:exe:TomlHighlighter"
, cabalComponentProject = Nothing
}
]
}
, dependencies = Just [ "src/Toml/Lexer.x" , "src/Toml/Parser.y" ]
}
it "handles the none case" $
decode [quoteStr|
[cradle.none]|]
`shouldBe`
Success [] (CradleConfig {
cradle = None NoneConfig,
dependencies = Nothing})