Eldritch Types

eldritch_types.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}

{- |
Module      : Main
Description : Type-driven design for domain modeling

A comprehensive tutorial file demonstrating advanced Haskell type system
features through a cohesive "eldritch horror" domain model. This file shows:

  * Smart constructors with newtypes (Section 1)
  * Algebraic sum types for representing choices (Section 2)
  * Product types using records for clarity (Section 3)
  * Functors for wrapping computational effects (Section 4)
  * Phantom types and DataKinds for compile-time state (Section 5)
  * GADTs for type-indexed evidence (Section 6)
  * Typeclasses for polymorphic behavior (Section 7)

All concepts are tied together in a self-contained domain: tracking
mysterious incidents involving eldritch entities and forbidden geometries.

Run with:  runghc eldritch_types.hs
Or:        ghc -O2 eldritch_types.hs && ./eldritch_types
-}

module Main where

import Data.Char (isAlpha, toUpper)
import Data.List (intercalate)
import Text.Printf (printf)

--------------------------------------------------------------------------------
-- SECTION 0: TEST HARNESS
-- A minimal, dependency-free testing framework
-- 
-- Rather than depend on external testing libraries, this section defines a
-- tiny testing framework that lets us validate all the type system examples
-- as we build them. This keeps the file self-contained and runnable with
-- just `runghc`.
--------------------------------------------------------------------------------

{- | The result of a test case: either it passes, or fails with a message. -}
data TestResult = Pass | Fail String deriving (Eq, Show)

{- | Simple assertion: convert a boolean and message into a TestResult.
     If the condition is true, the test passes. If false, it fails with
     the given message. -}
assert :: Bool -> String -> TestResult
assert True  _   = Pass
assert False msg = Fail msg

{- | Equality assertion: check if two values are equal (using Eq).
     If they match, the test passes. Otherwise, it fails with details
     showing both the expected and actual values. -}
assertEq :: (Eq a, Show a) => a -> a -> String -> TestResult
assertEq expected actual msg =
  if expected == actual then Pass
  else Fail (msg <> "\n  expected: " <> show expected <> "\n  actual:   " <> show actual)

{- | The test runner: takes a list of (test name, test result) pairs,
     prints each result, and summarizes how many passed and failed.
     This harness is intentionally simple to keep focus on type design. -}
runTests :: [(String, TestResult)] -> IO ()
runTests cases = do
  putStrLn "== The Unwholesome Test Suite =="
  let (passes, fails) = foldr collect (0 :: Int, []) cases
  mapM_ printCase cases
  putStrLn ""
  putStrLn (printf "Passed: %d" passes)
  putStrLn (printf "Failed: %d" (length fails))
  if null fails
    then putStrLn "Status: The stars are (temporarily) right."
    else do
      putStrLn "Status: Reality leaked."
      putStrLn "Failures:"
      mapM_ (\(name, why) -> putStrLn (" - " <> name <> ": " <> why)) fails
 where
  {- | Count passing and failing tests. Pattern match on TestResult to
       categorize each test. -}
  collect (name, res) (p, fs) =
    case res of
      Pass      -> (p + 1, fs)
      Fail why  -> (p, (name, why) : fs)

  {- | Format each test result for display. -}
  printCase (name, res) =
    case res of
      Pass     -> putStrLn ("[PASS] " <> name)
      Fail why -> putStrLn ("[FAIL] " <> name <> " — " <> oneLine why)

  {- | Truncate error messages to fit on one line (120 chars max). -}
  oneLine = take 120 . filter (/= '\n')

--------------------------------------------------------------------------------
-- SECTION 1: NEWTYPES FOR DOMAIN MEANING
-- Smart constructors and validation
--
-- A `newtype` is a wrapper around an existing type that gives it a distinct
-- meaning. Unlike type aliases, a newtype is distinct at compile time but has
-- zero runtime cost (the wrapper is erased during compilation).
--
-- Key insight: by using a newtype + smart constructor, we prevent invalid
-- values from being constructed in the first place, making illegal states
-- impossible to represent.
--------------------------------------------------------------------------------

{- | A CultistName represents the name of a cultist.
  
     We use `newtype` (not a plain `String`) to:
       1. Give the name semantic meaning in our domain
       2. Restrict what strings can be valid names (via mkCultistName)
       3. Let the compiler prevent accidentally mixing CultistName
          with other strings
  
     The smart constructor mkCultistName enforces the invariant that
     names must be non-empty and alphabetic (plus spaces). This means
     we can never construct an invalid CultistName through normal code paths.
-}
newtype CultistName = CultistName String deriving (Eq, Ord)

{- | Show instance for CultistName: display the underlying string. -}
instance Show CultistName where
  show (CultistName s) = s

{- | Smart constructor for CultistName.
  
     Rather than exposing the CultistName constructor directly, we provide
     mkCultistName which validates the input. This is a common pattern:
  
       - It returns Either String CultistName: Left if invalid, Right if valid
       - It trims whitespace
       - It checks that all characters are alphabetic or spaces
  
     By restricting construction this way, we guarantee that any CultistName
     value in our program satisfies these invariants.
-}
mkCultistName :: String -> Either String CultistName
mkCultistName raw =
  let trimmed = trim raw
  in if null trimmed
        then Left "CultistName cannot be empty."
     else if all (\c -> isAlpha c || c == ' ') trimmed
        then Right (CultistName trimmed)
        else Left "CultistName must contain only letters/spaces."

{- | Helper: trim leading and trailing spaces from a string.
  
     Implementation: reverse the string, drop spaces from the front,
     reverse again, then repeat. Simple and pure, though not the most
     efficient approach for very long strings.
-}
trim :: String -> String
trim = dropWhile (== ' ') . reverse . dropWhile (== ' ') . reverse

--------------------------------------------------------------------------------
-- SECTION 2: ALGEBRAIC SUM TYPES
-- Representing choices and possibilities
--
-- A sum type (or coproduct) represents "one of several possibilities."
-- In Haskell, we use the `|` symbol to separate alternatives.
--
-- Key insight: sum types let us enumerate all possible cases, and the
-- compiler enforces that we handle every case when pattern matching.
--------------------------------------------------------------------------------

{- | Forbidden geometries represent bizarre spatial configurations.
  
     This is a sum type with three alternatives:
       - NonEuclideanAngle: a degree measure that breaks normal geometry
       - CyclopeanArc: a count of massive stone blocks
       - ImpossibleSpiral: a fractal structure with turns and layers
  
     Each alternative can carry different data. This lets us represent
     different kinds of geometry with appropriate information for each kind.
-}
data Geometry
  = NonEuclideanAngle Double     -- ^ Angle in degrees (but not really)
  | CyclopeanArc Int             -- ^ Number of blocks
  | ImpossibleSpiral Int Int     -- ^ (turns, layers)
  deriving (Eq, Show)

{- | Entities represent eldritch creatures and phenomena.
  
     This is a sum type with four alternatives:
       - Dagon: a sea creature of ancient origin
       - Nyarlathotep: a shapeshifting chaos entity
       - Shoggoth: a mass of protoplasm with an integer mass factor
       - TheColourOutOfSpace: a chromatic anomaly
  
     Notice that Shoggoth carries data (the mass), while the others are
     simple enumeration values. This flexibility is the power of sum types.
-}
data Entity
  = Dagon
  | Nyarlathotep
  | Shoggoth Int                 -- ^ Mass factor (arbitrary units)
  | TheColourOutOfSpace
  deriving (Eq, Show)

{- | Compute a threat level (1-10) for an entity.
  
     This function uses pattern matching to handle each alternative.
     The compiler ensures we cover all cases. For Shoggoth, the threat
     depends on mass: higher mass = higher threat, but capped at 10.
  
     Key principle: exhaustive pattern matching means we can never forget
     to handle a case, and the compiler will warn us if a new case is added.
-}
entityThreat :: Entity -> Int
entityThreat e =
  case e of
    Dagon              -> 7
    Nyarlathotep       -> 10
    Shoggoth mass      -> min 10 (3 + mass `div` 2)
    TheColourOutOfSpace-> 9

--------------------------------------------------------------------------------
-- SECTION 3: PRODUCT TYPES (RECORDS)
-- Grouping related data with named fields
--
-- A product type (or record) groups multiple values together.
-- In Haskell, records provide named field accessors, making code self-documenting.
--
-- Key insight: records are products because they require ALL fields to be
-- present (unlike sum types where you pick ONE alternative).
--------------------------------------------------------------------------------

{- | A Location describes a place where something happens.
  
     This is a product type with two fields:
       - locName: the name of the location
       - locGeometry: the spatial properties of the location
  
     Record syntax (with `{ ... }`) gives us:
       - Named field accessors: locName loc, locGeometry loc
       - Pattern matching with named fields
       - Readable field order in the definition
-}
data Location = Location
  { locName     :: String
  , locGeometry :: Geometry
  } deriving (Eq, Show)

{- | An Incident is a report of something happening at a location.
  
     This product type combines:
       - who: the cultist involved (using our validated CultistName)
       - whereAt: the location where it occurred
       - what: the entity that appeared
       - witnessCount: how many people saw it
  
     By grouping these fields in a record, we make it clear what information
     belongs together, and the field names self-document the intent.
-}
data Incident = Incident
  { who           :: CultistName
  , whereAt       :: Location
  , what          :: Entity
  , witnessCount  :: Int
  } deriving (Eq, Show)

{- | Compute a severity score (integer) for an incident.
  
     The severity combines three factors:
       1. The base threat of the entity (entityThreat)
       2. A bonus based on the geometry (stranger = more severe)
       3. A witness bonus (more witnesses = more evidence = more severe)
  
     This function demonstrates composing logic across multiple record fields
     and nested pattern matching. We access fields using record accessors
     (whereAt i, what i, etc.) for clarity.
-}
incidentSeverity :: Incident -> Int
incidentSeverity i =
  let base = entityThreat (what i)
      geomBonus = case locGeometry (whereAt i) of
        NonEuclideanAngle deg -> if deg > 91 then 2 else 1
        CyclopeanArc blocks   -> if blocks >= 13 then 2 else 1
        ImpossibleSpiral t l  -> if t*l >= 20 then 3 else 2
      witnessBonus = min 3 (witnessCount i `div` 2)
  in base + geomBonus + witnessBonus

--------------------------------------------------------------------------------
-- SECTION 4: FUNCTORS FOR EFFECTS
-- Wrapping and composing computations
--
-- A Functor is a type that can be mapped over. The key method is `fmap`,
-- which applies a function to a value "inside" the functor.
--
-- Key insight: functors let us represent computations or side effects
-- (like sanity loss) while keeping the structure of the data intact.
--------------------------------------------------------------------------------

{- | The Sanity type wraps a value alongside a sanity delta (an integer).
  
     In a game context, the delta represents how much sanity is lost when
     encountering something. We pair this delta with a value so that effects
     can be composed and tracked.
  
     The `newtype` definition with `getSanity :: (Int, a)` means:
       - The sanity delta is an Int
       - The wrapped value has type `a` (polymorphic)
  
     By deriving Functor, we get fmap for free: we can apply a function
     to the `a` part while leaving the sanity delta untouched.
-}
newtype Sanity a = Sanity { getSanity :: (Int, a) }
  deriving (Eq, Show, Functor)

{- | Apply damage (loss of sanity) to a value.
  
     This constructs a Sanity effect with a negative delta (damage is a loss).
     We use negate and abs to ensure the damage is always negative.
  
     Example usage:
       damage 5 "I saw something" -> Sanity (-5, "I saw something")
-}
damage :: Int -> a -> Sanity a
damage d x = Sanity (negate (abs d), x)

{- | Combine two Sanity effects.
  
     When two things happen (e.g., two encounters), we combine their effects by:
       1. Adding the sanity deltas
       2. Pairing the wrapped values together as a tuple
  
     This shows how Functors can be composed: we track cumulative damage
     while keeping both pieces of information.
-}
combineSanity :: Sanity a -> Sanity b -> Sanity (a, b)
combineSanity (Sanity (s1, a)) (Sanity (s2, b)) = Sanity (s1 + s2, (a, b))

--------------------------------------------------------------------------------
-- SECTION 5: PHANTOM TYPES WITH DATAKINDS
-- Compile-time state tracking
--
-- A phantom type parameter is a type variable that appears in the type
-- but not in the value. Using DataKinds, we can promote a data type to
-- the kind level, giving us type-level programming.
--
-- Key insight: phantom types let us encode state distinctions that are
-- checked at compile time, preventing incorrect state transitions.
--------------------------------------------------------------------------------

{- | The SealState is a promotion to the kind level (via DataKinds).
  
     This defines a kind (a type for types) with two inhabitants:
       - 'Sealed: a sealed resource
       - 'Unsealed: an unsealed resource
  
     (Note the leading quotes ' which indicate we're using kind-level data,
      not value-level constructors.)
-}
data SealState = Sealed | Unsealed

{- | A Tome is a magical book with a phantom type parameter for its state.
  
     The `Tome (s :: SealState)` means:
       - s is a phantom type parameter (it appears in the type but not the data)
       - s is a SealState (either 'Sealed or 'Unsealed)
       - All Tome values have the same underlying structure (just a title)
  
     Why phantom? The state is purely for compile-time tracking. At runtime,
     a Sealed tome and Unsealed tome are the same. But the type system
     prevents mixing them up.
  
     Example:
       let sealed :: Tome 'Sealed = Tome "Necronomicon"
       let unsealed :: Tome 'Unsealed = Tome "De Vermis Mysteriis"
       -- These have different types, so we can't accidentally use one where
       -- the other is expected.
-}
newtype Tome (s :: SealState) = Tome
  { tomeTitle :: String
  } deriving (Eq, Show)

{- | Seal an unsealed tome.
  
     This function takes only a Tome 'Unsealed and returns a Tome 'Sealed.
     The type signature enforces that we can only seal something that is
     already unsealed. At compile time, if someone tries to seal a sealed
     tome, it will be a type error.
  
     At runtime, the operation is trivial (just wrapping), but the types
     prevent logical errors.
-}
seal :: Tome 'Unsealed -> Tome 'Sealed
seal (Tome t) = Tome t

{- | Attempt to unseal a sealed tome.
  
     Unsealing is a runtime operation that can fail (not all tomes allow
     unsealing). The return type is Either String (Tome 'Unsealed):
       - Left: unsealing failed with an error message
       - Right: unsealing succeeded, and we have an Unsealed tome
  
     Special case: the Necronomicon refuses to be unsealed. This shows how
     we can mix compile-time guarantees (type state) with runtime logic
     (checking specific titles).
-}
unseal :: Tome 'Sealed -> Either String (Tome 'Unsealed)
unseal (Tome t)
  | map toUpper t == "NECRONOMICON" = Left "That title refuses to be unsealed (policy of the universe)."
  | otherwise = Right (Tome t)

--------------------------------------------------------------------------------
-- SECTION 6: GADTs (GENERALIZED ALGEBRAIC DATA TYPES)
-- Type-indexed data and typed evidence
--
-- A GADT lets each constructor specify different types for the same type
-- parameter. This is more powerful than regular sum types because it allows
-- type-indexed behavior.
--
-- Key insight: GADTs capture "evidence" that a property holds, enabling
-- safe and type-driven computation.
--------------------------------------------------------------------------------

{- | Readable is a GADT that captures whether a Tome can be read.
  
     Unlike a regular sum type, the two constructors specify different
     state types:
       - CanRead wraps a Tome 'Unsealed: evidence that the tome is readable
       - Cannot wraps a Tome 'Sealed: evidence that the tome is unreadable
  
     The key power: when we pattern match on a Readable, the type system
     knows which state the tome is in. If you match on CanRead, the type
     system proves the tome is 'Unsealed and lets you read it.
  
     Example:
       let sealed_tome :: Tome 'Sealed = ...
       let evidence :: Readable 'Sealed = Cannot sealed_tome
       -- The evidence parameter matches the tome's seal state
-}
data Readable (s :: SealState) where
  CanRead :: Tome 'Unsealed -> Readable 'Unsealed
  Cannot  :: Tome 'Sealed   -> Readable 'Sealed

deriving instance Show (Readable s)

{- | Construct evidence for a sealed tome.
  
     A sealed tome cannot be read, so we provide the evidence: Cannot.
     This function bridges between the Tome type and the Readable GADT.
-}
attemptReadSealed :: Tome 'Sealed -> Readable 'Sealed
attemptReadSealed = Cannot

{- | Construct evidence for an unsealed tome.
  
     An unsealed tome can be read, so we provide the evidence: CanRead.
-}
attemptReadUnsealed :: Tome 'Unsealed -> Readable 'Unsealed
attemptReadUnsealed = CanRead

{- | Read a tome given evidence of its readability.
  
     The function takes a Readable value (evidence) and returns either
     an error or the text of the tome.
  
     The GADT ensures type safety: if you try to read a Sealed tome,
     the type won't match (Cannot doesn't contain the tome's text),
     and you'll get a type error at compile time, not a runtime crash.
-}
readTome :: Readable s -> Either String String
readTome r =
  case r of
    Cannot (Tome t) -> Left ("The tome \"" <> t <> "\" is sealed. Your eyeballs bounce off it.")
    CanRead (Tome t)-> Right ("You read \"" <> t <> "\". Some angles now feel judgmental.")

--------------------------------------------------------------------------------
-- SECTION 7: TYPECLASSES
-- Polymorphic behavior via type-directed dispatch
--
-- A typeclass defines a set of functions that different types can implement.
-- When we call a typeclass function, Haskell selects the right implementation
-- based on the type of the argument.
--
-- Key insight: typeclasses allow polymorphic functions without losing type safety.
-- The compiler resolves which instance to use at compile time.
--------------------------------------------------------------------------------

{- | The Dread typeclass: anything in this class can describe itself as "dread."
  
     This is used for pretty-printing domain objects in a human-readable way.
     By defining a typeclass, we can add new instances (new types that can be
     dreadfully described) without modifying the typeclass itself.
-}
class Dread a where
  {- | Convert a value to a dreadful description (a String). -}
  dread :: a -> String

{- | Instance: Entity can be described as dread.
  
     Each entity has a unique description that captures its nature in the domain.
     Pattern matching ensures we handle all entity variants.
-}
instance Dread Entity where
  dread Dagon               = "Dagon (wet footsteps, ancient hunger)"
  dread Nyarlathotep        = "Nyarlathotep (smiling masks, bad bargains)"
  dread (Shoggoth m)        = "Shoggoth x" <> show m <> " (protoplasmic bureaucracy)"
  dread TheColourOutOfSpace = "The Colour Out of Space (chromatic wrongness)"

{- | Instance: Geometry can be described as dread.
  
     Each geometry type gets a description that emphasizes its wrongness.
-}
instance Dread Geometry where
  dread (NonEuclideanAngle deg) = "Non-Euclidean angle: " <> show deg <> "° (lies)"
  dread (CyclopeanArc n)        = "Cyclopean arc of " <> show n <> " blocks"
  dread (ImpossibleSpiral t l)  = "Impossible spiral (" <> show t <> " turns, " <> show l <> " layers)"

{- | Instance: Incident can be described as dread.
  
     An incident report uses the Dread instances of its component parts
     (entity and geometry) to build a readable report. This shows how instances
     can be compositional: we reuse the Entity and Geometry instances.
-}
instance Dread Incident where
  dread i =
    intercalate "\n"
      [ "Incident Report"
      , "  Cultist: " <> show (who i)
      , "  Location: " <> locName (whereAt i)
      , "  Geometry: " <> dread (locGeometry (whereAt i))
      , "  Entity:   " <> dread (what i)
      , "  Witnesses:" <> show (witnessCount i)
      , "  Severity: " <> show (incidentSeverity i)
      ]

--------------------------------------------------------------------------------
-- MAIN: DEMONSTRATION AND TESTS
-- Putting it all together
--------------------------------------------------------------------------------

{- | The main entry point: run all tests and display sample output. -}
main :: IO ()
main = do
  let tests =
        [ ("mkCultistName accepts letters/spaces",
            case mkCultistName "Abdul Alhazred" of
              Right _ -> Pass
              Left e  -> Fail e
          )

        , ("mkCultistName rejects empty",
            case mkCultistName "   " of
              Left _  -> Pass
              Right _ -> Fail "Expected rejection."
          )

        , ("entityThreat increases with Shoggoth mass (roughly)",
            assertEq 6 (entityThreat (Shoggoth 6)) "Threat calc mismatch."
          )

        , ("incidentSeverity combines entity + geometry + witnesses",
            let Right cn = mkCultistName "Henry Armitage"
                loc = Location "Miskatonic Annex" (ImpossibleSpiral 5 5) -- 25 => geomBonus 3
                inc = Incident cn loc Nyarlathotep 4 -- base 10 + geom 3 + witness 2 => 15
            in assertEq 15 (incidentSeverity inc) "Severity mismatch."
          )

        , ("Sanity damage is negative",
            let Sanity (s, _) = damage 3 "peek"
            in assertEq (-3) s "Damage should subtract sanity."
          )

        , ("Sanity combines additively",
            let a = damage 2 "a"
                b = damage 5 "b"
                Sanity (s, _) = combineSanity a b
            in assertEq (-7) s "Combined sanity mismatch."
          )

        , ("Unsealing a normal sealed tome works",
            let sealed = Tome "Liber Ivonis" :: Tome 'Sealed
            in case unseal sealed of
                 Right _ -> Pass
                 Left e  -> Fail e
          )

        , ("Unsealing NECRONOMICON is refused",
            let sealed = Tome "Necronomicon" :: Tome 'Sealed
            in case unseal sealed of
                 Left _  -> Pass
                 Right _ -> Fail "Expected refusal."
          )

        , ("Reading sealed tome fails",
            let sealed = Tome "Cultes des Goules" :: Tome 'Sealed
            in case readTome (attemptReadSealed sealed) of
                 Left _  -> Pass
                 Right _ -> Fail "Expected read failure."
          )

        , ("Reading unsealed tome succeeds",
            let unsealedT = Tome "De Vermis Mysteriis" :: Tome 'Unsealed
            in case readTome (attemptReadUnsealed unsealedT) of
                 Right _ -> Pass
                 Left e  -> Fail e
          )
        ]

  runTests tests

  putStrLn "\n== Sample output (dread pretty-printer) =="
  case mkCultistName "Randolph Carter" of
    Left err -> putStrLn ("Name error: " <> err)
    Right cn -> do
      let loc = Location "The Nameless City" (CyclopeanArc 13)
          inc = Incident cn loc TheColourOutOfSpace 3
      putStrLn (dread inc)