Internal.hs

-- | This internal module is mostly here to prevent CPP conflicting with Haskell
-- comments.
module Hakyll.Core.Identifier.Pattern.Internal
    ( GlobComponent (..)
    , Pattern (..)
    ) where


--------------------------------------------------------------------------------
import           Data.Binary            (Binary (..), getWord8, putWord8)
import           Data.Set               (Set)


--------------------------------------------------------------------------------
import           Hakyll.Core.Identifier


--------------------------------------------------------------------------------
-- | Elements of a glob pattern
data GlobComponent
    = Capture
    | CaptureMany
    | Literal String
    deriving (Eq, Show)


--------------------------------------------------------------------------------
instance Binary GlobComponent where
    put Capture     = putWord8 0
    put CaptureMany = putWord8 1
    put (Literal s) = putWord8 2 >> put s

    get = getWord8 >>= \t -> case t of
        0 -> pure Capture
        1 -> pure CaptureMany
        2 -> Literal <$> get
        _ -> error "Data.Binary.get: Invalid GlobComponent"


--------------------------------------------------------------------------------
-- | Type that allows matching on identifiers
data Pattern
    = Everything
    | Complement Pattern
    | And Pattern Pattern
    | Glob [GlobComponent]
    | List (Set Identifier)
    | Regex String
    | Version (Maybe String)
    deriving (Show)


--------------------------------------------------------------------------------
instance Binary Pattern where
    put Everything     = putWord8 0
    put (Complement p) = putWord8 1 >> put p
    put (And x y)      = putWord8 2 >> put x >> put y
    put (Glob g)       = putWord8 3 >> put g
    put (List is)      = putWord8 4 >> put is
    put (Regex r)      = putWord8 5 >> put r
    put (Version v)    = putWord8 6 >> put v

    get = getWord8 >>= \t -> case t of
        0 -> pure Everything
        1 -> Complement <$> get
        2 -> And <$> get <*> get
        3 -> Glob <$> get
        4 -> List <$> get
        5 -> Regex <$> get
        _ -> Version <$> get


--------------------------------------------------------------------------------
instance Semigroup Pattern where
    (<>) = And

instance Monoid Pattern where
    mempty  = Everything
    mappend = (<>)