RestrictConstructors.hs

{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeOperators, TypeFamilies, PolyKinds, ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module RestrictConstructors where

import Data.Word
import Data.Int

data Mode =
    ImpliedMode
    | AccumulatorMode
    | ImmediateMode
    | RelativeMode
    | ZeroPageRelativeMode
    | AbsoluteMode
    | AbsoluteXMode
    | AbsoluteYMode
    | ZeroPageMode
    | ZeroPageXMode
    | ZeroPageYMode
    | ZeroPageIndirectMode
    | IndirectMode
    | IndirectXMode
    | IndirectYMode

data AddressingMode (m :: Mode) where
    Implied :: AddressingMode 'ImpliedMode
    Accumulator :: AddressingMode 'AccumulatorMode
    Immediate :: Word8 -> AddressingMode 'ImmediateMode
    Relative :: Int8 -> AddressingMode 'RelativeMode
    ZeroPageRelative :: Int8 -> AddressingMode 'ZeroPageRelativeMode
    Absolute :: Word16 -> AddressingMode 'AbsoluteMode
    AbsoluteX :: Word16 -> AddressingMode 'AbsoluteXMode
    AbsoluteY :: Word16 -> AddressingMode 'AbsoluteYMode
    ZeroPage :: Word8 -> AddressingMode 'ZeroPageMode
    ZeroPageX :: Word8 -> AddressingMode 'ZeroPageXMode
    ZeroPageY :: Word8 -> AddressingMode 'ZeroPageYMode
    ZeroPageIndirect :: Word8 -> AddressingMode 'ZeroPageIndirectMode
    Indirect :: Word16 -> AddressingMode 'IndirectMode
    IndirectX :: Word8 -> AddressingMode 'IndirectXMode
    IndirectY :: Word8 -> AddressingMode 'IndirectYMode

data IsAccepted = Accepted | NotAccepted

type family Elem (x :: k) xs :: IsAccepted where
    Elem x (x ': xs) = 'Accepted
    Elem x (y ': xs) = Elem x xs
    Elem x '[] = 'NotAccepted

type AcceptedMode m ms = Elem m ms ~ 'Accepted

bbr0 :: AcceptedMode m '[ 'ZeroPageRelativeMode] => AddressingMode m -> ()
bbr0 (ZeroPageRelative _) = ()
-- bbr0 Implied = 1 -- compile time error if you even try to define this

bit :: AcceptedMode m '[ 'ImmediateMode, 'ZeroPageMode, 'ZeroPageXMode, 'AbsoluteMode, 'AbsoluteXMode] => AddressingMode m -> ()
bit (Immediate _) = () -- non-exhaustive pattern match warning for the rest of the specified modes

-- test = bbr0 Implied -- compile time error if called with wrong mode