Skip to content
Snippets Groups Projects
Select Git revision
  • ac96dea6cb2972cd421b8d1c0fa15a6a47546e8d
  • main default protected
  • 75389691-a67c-422a-91e9-aa58bfb5-main-patch-32205
  • test-pipe
  • extended-scripts
  • structured-badges
  • guix-pipeline
  • cabal-pipeline
8 results

Types.hs

Blame
  • Types.hs 4.05 KiB
    {-# LANGUAGE DeriveAnyClass    #-}
    {-# LANGUAGE DeriveGeneric     #-}
    {-# LANGUAGE LambdaCase        #-}
    {-# LANGUAGE NamedFieldPuns    #-}
    {-# LANGUAGE OverloadedStrings #-}
    
    
    -- | basic types for the linter to eat and produce
    -- The dark magic making thse useful is in LintWriter
    module Types
      ( Level(..)
      , Lint(..)
      , Dep(..)
      , Hint(..)
      , hint
      , lintLevel
      , lintsToHints
      ) where
    
    import           Universum
    
    import           Control.Monad.Trans.Maybe ()
    import           Data.Aeson                (FromJSON, ToJSON (toJSON),
                                                ToJSONKey, (.=))
    
    import           Badges                    (Badge)
    import qualified Data.Aeson                as A
    import           Paths                     (RelPath)
    import           Util                      (PrettyPrint (..))
    import           WithCli                   (Argument, atomicArgumentsParser)
    import           WithCli.Pure              (Argument (argumentType, parseArgument),
                                                HasArguments (argumentsParser))
    
    
    -- | Levels of errors and warnings, collectively called
    -- "Hints" until I can think of some better name
    data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
      deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData)
    
    instance Argument Level where
      argumentType Proxy = "Lint Level"
      parseArgument arg = case arg of
        "info"       -> Just Info
        "suggestion" -> Just Suggestion
        "warning"    -> Just Warning
        "forbidden"  -> Just Forbidden
        "error"      -> Just Error
        "fatal"      -> Just Fatal
        _            -> Nothing
    
    
    instance HasArguments Level where
       argumentsParser = atomicArgumentsParser
    
    -- | a hint comes with an explanation (and a level), or is a dependency
    -- (in which case it'll be otherwise treated as an info hint)
    data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge
      deriving (Ord, Eq, Generic, ToJSONKey)
    
    data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
      deriving (Generic, Ord, Eq, NFData)
    
    data Hint = Hint
      { hintLevel :: Level
      , hintMsg   :: Text
      } deriving (Generic, Ord, Eq, NFData)
    
    -- | shorter constructor (called hint because (a) older name and
    -- (b) lint also exists and is monadic)
    hint :: Level -> Text -> Lint
    hint level msg = Lint Hint { hintLevel = level, hintMsg = msg }
    
    -- | dependencies just have level Info
    lintLevel :: Lint -> Level
    lintLevel (Lint h) = hintLevel h
    lintLevel _        = Info
    
    lintsToHints :: [Lint] -> [Hint]
    lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing})
    
    instance PrettyPrint Lint where
      prettyprint (Lint  Hint { hintMsg, hintLevel } ) =
        "  " <> show hintLevel <> ": " <> hintMsg
      prettyprint (Depends dep) =
        "  Info: found dependency: " <> prettyprint dep
      prettyprint (Offers dep) =
        "  Info: map offers entrypoint " <> prettyprint dep
      prettyprint (Badge _) =
        "  Info: found a badge."
    
    instance PrettyPrint Hint where
      prettyprint (Hint level msg) = "  " <> show level <> ": " <> msg
    
    instance ToJSON Lint where
      toJSON (Lint h) = toJSON h
      toJSON (Depends dep) = A.object
        [ "msg" .= prettyprint dep
        , "level" .= A.String "Dependency Info" ]
      toJSON (Offers l) = A.object
        [ "msg" .= prettyprint l
        , "level" .= A.String "Entrypoint Info" ]
      toJSON (Badge _) = A.object
        [ "msg" .= A.String "found a badge"
        , "level" .= A.String "Badge Info"]
    
    instance ToJSON Hint where
      toJSON (Hint l m) = A.object
        [ "msg" .= m, "level" .= l ]
    
    instance ToJSON Dep where
      toJSON  = \case
        Local text    -> json "local" $ prettyprint text
        Link text     -> json "link" text
        MapLink text  -> json "mapservice" text
        LocalMap text -> json "map" $ prettyprint text
        where
          json :: A.Value -> Text -> A.Value
          json kind text = A.object [ "kind" .= kind, "dep" .= text ]
    
    instance PrettyPrint Dep where
      prettyprint = \case
        Local dep    -> "[local dep: " <> prettyprint dep <> "]"
        Link dep     -> "[link dep: " <> dep <> "]"
        MapLink dep  -> "[map service dep: " <> dep <> "]"
        LocalMap dep -> "[local map dep: " <> prettyprint dep <> "]"