Amostras da Linguagem Haskell

-- Haskell Hello World Examples

-- 1. Basic Hello World
mainBasic :: IO ()
mainBasic = putStrLn "Hello, World!"

-- 2. Hello World with function
greet :: String -> String
greet name = "Hello, " ++ name ++ "!"

mainWithFunction :: IO ()
mainWithFunction = putStrLn (greet "World")

-- 3. Hello World with multiple functions
sayHello :: String
sayHello = "Hello, World!"

greetPerson :: String -> String
greetPerson name = "Hello, " ++ name ++ "!"

mainWithMultipleFunctions :: IO ()
mainWithMultipleFunctions = do
    putStrLn sayHello
    putStrLn (greetPerson "Haskell")
    putStrLn (greetPerson "Functional Programming")

-- 4. Hello World with let binding
mainWithLetBinding :: IO ()
mainWithLetBinding = do
    let message = "Hello, World!"
    putStrLn message
    let greet name = "Hello, " ++ name ++ "!"
    putStrLn (greet "Haskell")

-- 5. Hello World with pattern matching
greetWithTime :: Int -> String
greetWithTime hour
    | hour < 12  = "Good morning, World!"
    | hour < 18  = "Good afternoon, World!"
    | otherwise = "Good evening, World!"

mainWithPatternMatching :: IO ()
mainWithPatternMatching = do
    putStrLn (greetWithTime 14)

-- 6. Hello World with list operations
greetings :: [String]
greetings = ["Hello", "Bonjour", "Hola", "Ciao", "こんにちは"]

printGreetings :: [String] -> IO ()
printGreetings [] = return ()
printGreetings (x:xs) = do
    putStrLn (x ++ ", World!")
    printGreetings xs

mainWithListOps :: IO ()
mainWithListOps = printGreetings greetings

-- 7. Hello World with map
mainWithMap :: IO ()
mainWithMap = mapM_ (g -> putStrLn (g ++ ", World!")) greetings

-- 8. Hello World with recursion
printGreetingsRec :: [String] -> IO ()
printGreetingsRec [] = putStrLn "Done!"
printGreetingsRec (x:xs) = do
    putStrLn (x ++ ", World!")
    printGreetingsRec xs

mainWithRecursion :: IO ()
mainWithRecursion = printGreetingsRec greetings

-- 9. Hello World with case expression
describeGreeting :: String -> String
describeGreeting greeting = case greeting of
    "Hello"    -> "English greeting"
    "Bonjour"  -> "French greeting"
    "Hola"     -> "Spanish greeting"
    "Ciao"     -> "Italian greeting"
    _          -> "Unknown greeting"

mainWithCase :: IO ()
mainWithCase = do
    let greeting = "Hello"
    putStrLn (greeting ++ ", World!")
    putStrLn (describeGreeting greeting)

-- 10. Hello World with input (simulation)
-- In a real program, you might use getLine
simulateGreetUser :: String -> IO ()
simulateGreetUser userName = putStrLn ("Hello, " ++ userName ++ "!")

mainWithInputSimulation :: IO ()
mainWithInputSimulation = simulateGreetUser "Haskell User"

-- Basic data types and type signatures

-- Integer types
intExample :: Int
intExample = 42

integerExample :: Integer
integerExample = 12345678901234567890

-- Floating point types
floatExample :: Float
floatExample = 3.14

doubleExample :: Double
doubleExample = 3.14159265359

-- String
stringExample :: String
stringExample = "Haskell"

-- Boolean
boolExample :: Bool
boolExample = True

-- List
listExample :: [Int]
listExample = [1, 2, 3, 4, 5]

-- Tuple
tupleExample :: (String, Int)
tupleExample = ("age", 25)

-- Maybe type
maybeExample :: Maybe String
maybeExample = Just "Haskell"

-- Either type
eitherExample :: Either String Int
eitherExample = Right 42

-- Basic functions

-- Addition with type signature
add :: Int -> Int -> Int
add x y = x + y

-- Function composition
addOne :: Int -> Int
addOne = (+1)

multiplyByTwo :: Int -> Int
multiplyByTwo = (*2)

-- Composed function
addOneAndMultiplyByTwo :: Int -> Int
addOneAndMultiplyByTwo = multiplyByTwo . addOne

-- Lambda expressions
doubleList :: [Int] -> [Int]
doubleList = map (*2)

-- Filter even numbers
evenNumbers :: [Int] -> [Int]
evenNumbers = filter even

-- Pattern matching
factorial :: Integer -> Integer
factorial 0 = 1
factorial n = n * factorial (n - 1)

-- List pattern matching
listLength :: [a] -> Int
listLength [] = 0
listLength (_:xs) = 1 + listLength xs

-- Guard clauses
describeNumber :: Int -> String
describeNumber n
    | n < 0     = "negative"
    | n == 0    = "zero"
    | n < 10    = "single digit"
    | even n    = "even"
    | otherwise = "odd"

-- Working with Maybe
safeDivide :: Double -> Double -> Maybe Double
safeDivide _ 0 = Nothing
safeDivide x y = Just (x / y)

describeMaybe :: Maybe String -> String
describeMaybe Nothing  = "No value"
describeMaybe (Just s) = "Value: " ++ s

-- Working with Either
divideWithError :: Double -> Double -> Either String Double
divideWithError _ 0 = Left "Division by zero"
divideWithError x y = Right (x / y)

describeEither :: Either String Double -> String
describeEither (Left err)  = "Error: " ++ err
describeEither (Right val) = "Result: " ++ show val

-- Higher-order functions
applyTwice :: (a -> a) -> a -> a
applyTwice f x = f (f x)

-- Example usage
double :: Int -> Int
double = (*2)

result :: Int
result = applyTwice double 3  -- (double (double 3)) = 12

-- Custom data types

-- Enum type
data Color = Red | Green | Blue | Yellow | Purple deriving (Show, Eq)

-- Product type
data Point = Point Double Double deriving (Show)

distance :: Point -> Point -> Double
distance (Point x1 y1) (Point x2 y2) =
    sqrt ((x2 - x1)^2 + (y2 - y1)^2)

-- Sum type with parameters
data Shape = Circle Double Double Double
           | Rectangle Double Double Double Double
           deriving (Show)

area :: Shape -> Double
area (Circle _ _ r) = pi * r^2
area (Rectangle w h _ _) = w * h

-- Record syntax
data Person = Person {
    name :: String,
    age :: Int,
    email :: String
} deriving (Show, Eq)

-- Accessing record fields
personName :: Person -> String
personName = name

personAge :: Person -> Int
personAge = age

-- Type classes

-- Show instance for custom type
data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Eq)

instance Show a => Show (Tree a) where
    show (Leaf x) = "Leaf " ++ show x
    show (Node left right) = "Node (" ++ show left ++ ") (" ++ show right ++ ")"

-- Eq instance
instance Eq Color where
    Red == Red = True
    Green == Green = True
    Blue == Blue = True
    Yellow == Yellow = True
    Purple == Purple = True
    _ == _ = False

-- Custom type class
class Describable a where
    describe :: a -> String

instance Describable Person where
    describe p = name p ++ " is " ++ show (age p) ++ " years old"

instance Describable Color where
    describe Red = "Red like a rose"
    describe Green = "Green like grass"
    describe Blue = "Blue like the sky"
    describe Yellow = "Yellow like the sun"
    describe Purple = "Purple like royalty"

-- IO Actions
greetAndRespond :: IO ()
greetAndRespond = do
    putStrLn "Hello! What's your name?"
    -- In a real program: userName <- getLine
    let userName = "Haskell Programmer"  -- Simulated input
    putStrLn ("Nice to meet you, " ++ userName ++ "!")
    putStrLn "Haskell is a purely functional programming language."

-- IO with let bindings
calculateAndPrint :: IO ()
calculateAndPrint = do
    let x = 10
    let y = 20
    let sum = x + y
    putStrLn ("The sum of " ++ show x ++ " and " ++ show y ++ " is " ++ show sum)

-- IO with when
printIfPositive :: Int -> IO ()
printIfPositive n = when (n > 0) $ putStrLn (show n ++ " is positive")

-- List comprehensions
squares :: [Int]
squares = [x^2 | x <- [1..10]]

evenSquares :: [Int]
evenSquares = [x^2 | x <- [1..10], even x]

pairs :: [(Int, Int)]
pairs = [(x, y) | x <- [1..3], y <- [1..3], x /= y]

-- Function application operator
-- $ operator (function application)
example1 :: String
example1 = show (length [1,2,3,4,5])
example2 :: String
example2 = show $ length [1,2,3,4,5]  -- Same as example1

-- Function composition operator
-- . operator (function composition)
example3 :: Int
example3 = length (filter even [1..20])
example4 :: Int
example4 = (length . filter even) [1..20]  -- Same as example3

-- Point-free style
isEvenLength :: [a] -> Bool
isEvenLength = even . length

-- Main function that demonstrates various concepts
main :: IO ()
main = do
    putStrLn "=== Haskell Hello World Examples ==="

    -- Basic output
    putStrLn "1. Basic Hello World:"
    putStrLn "Hello, World!"

    -- Function calls
    putStrLn "
2. Function calls:"
    putStrLn (greet "Haskell")

    -- Mathematical operations
    putStrLn "
3. Mathematical operations:"
    putStrLn (show (add 5 3))
    putStrLn (show result)

    -- List operations
    putStrLn "
4. List operations:"
    putStrLn (show squares)
    putStrLn (show evenSquares)

    -- Maybe and Either
    putStrLn "
5. Maybe and Either:"
    putStrLn (describeMaybe (safeDivide 10 2))
    putStrLn (describeMaybe (safeDivide 10 0))
    putStrLn (describeEither (divideWithError 10 2))
    putStrLn (describeEither (divideWithError 10 0))

    -- Custom types
    putStrLn "
6. Custom types:"
    let p = Person "Alice" 30 "[email protected]"
    putStrLn (show p)
    putStrLn (describe p)

    putStrLn (describe Red)

    -- Shapes
    putStrLn "
7. Shape areas:"
    let circle = Circle 0 0 5
    let rect = Rectangle 4 3 0 0
    putStrLn ("Circle area: " ++ show (area circle))
    putStrLn ("Rectangle area: " ++ show (area rect))

    -- Tree example
    putStrLn "
8. Tree:"
    let tree = Node (Leaf 1) (Node (Leaf 2) (Leaf 3))
    putStrLn (show tree)

    putStrLn "
=== Examples Complete! ==="

-- Haskell Functional Programming Patterns

import Control.Monad
import Data.List (sort, group, groupBy, sortBy)
import Data.Function (on)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Either (partitionEithers)

-- 1. Functor and Applicative patterns

-- Functor: fmap or <$> operator
processMaybe :: Maybe Int -> Maybe String
processMaybe = fmap show
-- Alternative: processMaybe = show <$>

-- Applicative: <*> operator
validateAge :: String -> Maybe Int
validateAge s
    | all isDigit s = Just (read s)
    | otherwise = Nothing

validateName :: String -> Maybe String
validateName s
    | null s     = Nothing
    | otherwise = Just s

-- Using Applicative to combine validations
validatePerson :: String -> String -> Maybe (String, Int)
validatePerson name age = (,) <$> validateName name <*> validateAge age

-- 2. Monad patterns

-- Maybe monad for sequential operations that might fail
safeDivide :: Double -> Double -> Maybe Double
safeDivide _ 0 = Nothing
safeDivide x y = Just (x / y)

safeRoot :: Double -> Maybe Double
safeRoot x
    | x < 0     = Nothing
    | otherwise = Just (sqrt x)

-- Compose Maybe operations with monadic bind
calculateResult :: Double -> Double -> Maybe Double
calculateResult x y = do
    quotient <- safeDivide x y
    result <- safeRoot quotient
    return result

-- Either monad for error handling
data ValidationError = EmptyName | InvalidAge String deriving (Show)

validatePersonEither :: String -> String -> Either ValidationError (String, Int)
validatePersonEither name age = do
    validName <- if null name
                 then Left EmptyName
                 else Right name
    validAge <- case reads age of
                 [(n, "")] | n >= 0 -> Right n
                 _ -> Left (InvalidAge age)
    return (validName, validAge)

-- List monad for combinations
pairs :: [a] -> [b] -> [(a, b)]
pairs xs ys = do
    x <- xs
    y <- ys
    return (x, y)

-- 3. Common functional patterns

-- Map and filter combination
numbers :: [Int]
numbers = [1..20]

evenSquares :: [Int]
evenSquares = map (^2) $ filter even numbers

-- Same with list comprehension
evenSquares' :: [Int]
evenSquares' = [x^2 | x <- numbers, even x]

-- Fold patterns
sumEven :: [Int] -> Int
sumEven = foldr (\x acc -> if even x then x + acc else acc) 0

-- Alternative with foldMap
sumEven' :: [Int] -> Int
sumEven' = foldMap (\x -> if even x then x else 0)

-- 4. Higher-order function patterns

-- Function composition for data transformation
data User = User { userId :: Int, userName :: String, userAge :: Int }
  deriving (Show)

userNames :: [User] -> [String]
userNames = map userName

adultUserNames :: [User] -> [String]
userNamesOlderThan :: Int -> [User] -> [String]
userNamesOlderThan age = map userName . filter (\u -> userAge u > age)

-- Point-free style
adultUserNames :: [User] -> [String]
adultUserNames = userNamesOlderThan 18

-- 5. Algebraic Data Type patterns

-- Expression tree
data Expr = Const Int
          | Add Expr Expr
          | Mul Expr Expr
          | Sub Expr Expr
          deriving (Show)

-- Pattern matching for evaluation
eval :: Expr -> Int
eval (Const n) = n
eval (Add e1 e2) = eval e1 + eval e2
eval (Mul e1 e2) = eval e1 * eval e2
eval (Sub e1 e2) = eval e1 - eval e2

-- Safe evaluation with Maybe
evalSafe :: Expr -> Maybe Int
evalSafe = go
  where
    go (Const n) = Just n
    go (Add e1 e2) = do
        v1 <- go e1
        v2 <- go e2
        return (v1 + v2)
    go (Mul e1 e2) = do
        v1 <- go e1
        v2 <- go e2
        return (v1 * v2)
    go (Sub e1 e2) = do
        v1 <- go e1
        v2 <- go e2
        return (v1 - v2)

-- 6. Functor, Applicative, Monad instances

-- Custom Maybe-like type
data Option a = None | Some a deriving (Show, Eq)

-- Functor instance
instance Functor Option where
    fmap _ None = None
    fmap f (Some x) = Some (f x)

-- Applicative instance
instance Applicative Option where
    pure = Some
    None <*> _ = None
    _ <*> None = None
    Some f <*> Some x = Some (f x)

-- Monad instance
instance Monad Option where
    return = pure
    None >>= _ = None
    Some x >>= f = f x

-- 7. Type class patterns

-- Comparison type class
class Comparable a where
    compareTo :: a -> a -> Ordering

instance Comparable Int where
    compareTo x y = compare x y

instance Comparable String where
    compareTo x y = compare x y

-- Generic maximum function
maximumBy :: Comparable a => [a] -> a
maximumBy [] = error "Empty list"
maximumBy [x] = x
maximumBy (x:xs) = case compareTo x (maximumBy xs) of
                     GT -> x
                     _  -> maximumBy xs

-- 8. Reader monad for dependency injection

-- Simple configuration
data Config = Config {
    debugMode :: Bool,
    maxRetries :: Int,
    timeout :: Int
} deriving (Show)

-- Reader monad type alias
type ConfigReader a = Reader Config a

-- Functions that use configuration
logMessage :: String -> ConfigReader ()
logMessage msg = do
    config <- ask
    when (debugMode config) $ liftIO $ putStrLn ("DEBUG: " ++ msg)

getTimeout :: ConfigReader Int
getTimeout = timeout <$> ask

-- Using Reader monad
processData :: String -> ConfigReader String
processData input = do
    logMessage ("Processing: " ++ input)
    timeout <- getTimeout
    liftIO $ threadDelay (timeout * 1000)  -- Simulate work
    return (reverse input)

-- 9. State monad patterns

-- Counter example using State monad
type Counter = State Int

increment :: Counter ()
increment = modify (+1)

getValue :: Counter Int
getValue = get

reset :: Counter ()
reset = put 0

-- Complex state operations
processCounter :: Counter String
processCounter = do
    current <- getValue
    increment
    increment
    newValue <- getValue
    return ("Old: " ++ show current ++ ", New: " ++ show newValue)

-- Running state computations
runCounterExample :: IO ()
runCounterExample = do
    let result = execState (replicate 5 increment) 0
    putStrLn ("Final counter value: " ++ show result)

-- 10. Lens patterns (simplified)

-- Data type with nested structure
data Address = Address {
    street :: String,
    city :: String,
    zipCode :: String
} deriving (Show, Eq)

data Company = Company {
    companyName :: String,
    companyAddress :: Address
} deriving (Show, Eq)

data Employee = Employee {
    empName :: String,
    empCompany :: Company,
    empSalary :: Double
} deriving (Show, Eq)

-- Simple lens-like functions
getCity :: Employee -> String
getCity = city . companyAddress

setCity :: String -> Employee -> Employee
setCity newCity emp = emp {
    empCompany = (empCompany emp) {
        companyAddress = (companyAddress (empCompany emp)) { city = newCity }
    }
}

-- 11. Foldable and Traversable patterns

-- Custom tree type
data Tree a = Empty | Node a (Tree a) (Tree a) deriving (Show, Eq)

-- Foldable instance
instance Foldable Tree where
    foldMap _ Empty = mempty
    foldMap f (Node x left right) = f x <> foldMap f left <> foldMap f right

-- Traversable instance
instance Traversable Tree where
    traverse _ Empty = pure Empty
    traverse f (Node x left right) =
        Node <$> f x <*> traverse f left <*> traverse f right

-- Tree operations using Foldable
treeSum :: Tree Int -> Int
treeSum = sum

treeToList :: Tree a -> [a]
treeToList = foldMap (:[])

-- 12. Lazy evaluation patterns

-- Infinite list
fibs :: [Integer]
fibs = 0 : 1 : zipWith (+) fibs (tail fibs)

-- Take first 10 Fibonacci numbers
firstTenFibs :: [Integer]
firstTenFibs = take 10 fibs

-- Prime number sieve
primes :: [Integer]
primes = sieve [2..]
  where
    sieve (p:xs) = p : sieve [x | x <- xs, x `mod` p /= 0]

-- First 10 primes
firstTenPrimes :: [Integer]
firstTenPrimes = take 10 primes

-- 13. Parser combinator patterns (simplified)

-- Simple parser type
newtype Parser a = Parser { parse :: String -> Maybe (a, String) }

instance Functor Parser where
    fmap f (Parser p) = Parser $ \input -> do
        (result, rest) <- p input
        return (f result, rest)

instance Applicative Parser where
    pure x = Parser $ \input -> return (x, input)

    Parser pf <*> Parser px = Parser $ \input -> do
        (f, rest1) <- pf input
        (x, rest2) <- px rest1
        return (f x, rest2)

-- Basic parsers
char :: Char -> Parser Char
char c = Parser $ \(x:xs) -> if x == c then return (c, xs) else Nothing

string :: String -> Parser String
string = traverse char

-- 14. Advanced type patterns

-- Phantom types for type safety
data Weight = Weight Double
data Height = Height Double

data PersonSafe = PersonSafe {
    psName :: String,
    psWeight :: Weight,
    psHeight :: Height
} deriving (Show)

-- Safe operations
bmi :: PersonSafe -> Double
bmi (PersonSafe _ (Weight w) (Height h)) = w / (h * h)

-- 15. Performance optimization patterns

-- Strictness annotation for performance
data StrictPair a b = StrictPair !a !b deriving (Show, Eq)

-- Bang patterns
sumBang :: [Int] -> Int
sumBang [] = 0
sumBang (x:xs) =
    let !restSum = sumBang xs
    in x + restSum

-- Main function demonstrating all patterns
main :: IO ()
main = do
    putStrLn "=== Haskell Functional Programming Patterns ==="

    -- Maybe examples
    putStrLn "\n1. Maybe patterns:"
    print $ validatePerson "Alice" "25"
    print $ validatePerson "" "25"
    print $ validatePerson "Alice" "invalid"

    -- Either examples
    putStrLn "\n2. Either patterns:"
    print $ validatePersonEither "Alice" "25"
    print $ validatePersonEither "" "25"

    -- Monad examples
    putStrLn "\n3. Monad patterns:"
    print $ calculateResult 16 4
    print $ calculateResult 4 0

    -- List monad
    putStrLn "\n4. List monad combinations:"
    print $ pairs [1,2] ['a','b']

    -- Expression evaluation
    putStrLn "\n5. Expression evaluation:"
    let expr = Add (Const 5) (Mul (Const 3) (Const 4))
    putStrLn $ "Expression: " ++ show expr
    putStrLn $ "Result: " ++ show (eval expr)
    putStrLn $ "Safe result: " ++ show (evalSafe expr)

    -- Tree operations
    putStrLn "\n6. Tree operations:"
    let tree = Node 2 (Node 1 Empty Empty) (Node 3 Empty Empty)
    putStrLn $ "Tree: " ++ show tree
    putStrLn $ "Tree sum: " ++ show (treeSum tree)
    putStrLn $ "Tree list: " ++ show (treeToList tree)

    -- Lazy evaluation
    putStrLn "\n7. Lazy evaluation:"
    putStrLn $ "First 10 Fibonacci numbers: " ++ show firstTenFibs
    putStrLn $ "First 10 primes: " ++ show firstTenPrimes

    -- Custom Option type
    putStrLn "\n8. Custom Option type:"
    print $ fmap (*2) (Some 5)
    print $ fmap (*2) None
    print $ Some (*) <*> Some 5 <*> Some 3
    print $ Some 5 >>= \x -> return (x * 2)

    putStrLn "\n=== Patterns Complete! ==="

-- Haskell Advanced Type System Examples

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}

import Data.Kind (Type)
import GHC.TypeLits
import Data.Proxy
import qualified Data.Text as T

-- 1. Type Families

-- Type family for container element types
type family Elem (container :: Type) :: Type
type instance Elem [a] = a
type instance Elem (Maybe a) = a

-- Type family for numeric promotion
type family Promote (a :: Type) :: Type
type instance Promote Int = Integer
type instance Promote Double = Double

-- Associated type families
class Container c where
    type Item c :: Type
    empty :: c
    insert :: Item c -> c -> c
    member :: Item c -> c -> Bool

instance Container [a] where
    type Item [a] = a
    empty = []
    insert = (:)
    member = elem

-- 2. GADTs (Generalized Algebraic Data Types)

-- Expression with type-level information
data Expr a where
    I :: Int -> Expr Int
    B :: Bool -> Expr Bool
    Add :: Expr Int -> Expr Int -> Expr Int
    Mul :: Expr Int -> Expr Int -> Expr Int
    If :: Expr Bool -> Expr a -> Expr a -> Expr a
    Eq  :: Expr Int -> Expr Int -> Expr Bool

-- Type-safe evaluation
eval :: Expr a -> a
eval (I n) = n
eval (B b) = b
eval (Add e1 e2) = eval e1 + eval e2
eval (Mul e1 e2) = eval e1 * eval e2
eval (If cond e1 e2) = if eval cond then eval e1 else eval e2
eval (Eq e1 e2) = eval e1 == eval e2

-- 3. Data Kinds and Type-level literals

-- Nat type for natural numbers
data Nat = Z | S Nat

-- Type-level lists
data HList (types :: [Type]) where
    HNil :: HList '[]
    (:#) :: t -> HList ts -> HList (t ': ts)

infixr 5 :#

-- Example usage
exampleList :: HList '[Int, String, Bool]
exampleList = 42 :# "hello" :# True :# HNil

-- Type-safe head function
hhead :: HList (t ': ts) -> t
hhead (x :# _) = x

-- 4. Dependent types with TypeLits

-- Vector with length in type
data Vec (n :: Nat) a where
    VNil :: Vec 0 a
    VCons :: a -> Vec n a -> Vec (n + 1) a

infixr 5 VCons

-- Safe head using type-level naturals
vhead :: Vec (n + 1) a -> a
vhead (VCons x _) = x

-- Vector append
vappend :: Vec n a -> Vec m a -> Vec (n + m) a
vappend VNil ys = ys
vappend (VCons x xs) ys = VCons x (vappend xs ys)

-- 5. Rank-N Types

-- Polymorphic function that takes polymorphic argument
-- forAll :: (forall a. a -> a) -> Int
-- forAll f = f 42

-- Continuation passing style
newtype Cont r a = Cont { runCont :: (a -> r) -> r }

instance Functor (Cont r) where
    fmap f (Cont g) = Cont $ \k -> g (k . f)

instance Applicative (Cont r) where
    pure x = Cont $ \k -> k x
    Cont cf <*> Cont cx = Cont $ \k -> cf (\f' -> cx (\x' -> k (f' x')))

instance Monad (Cont r) where
    return = pure
    Cont c >>= f = Cont $ \k -> c (\a -> runCont (f a) k)

-- 6. Existential Types

-- Hide the type parameter
data SomeBox = forall a. Show a => SomeBox a

instance Show SomeBox where
    showsPrec _ (SomeBox a) = showsPrec 0 a

-- Example usage
boxes :: [SomeBox]
boxes = [SomeBox 42, SomeBox "hello", SomeBox True]

-- 7. Type Classes with Complex Constraints

-- Multiple parameter type class
class Convertible a b where
    convert :: a -> b

instance Convertible Int String where
    convert = show

instance Convertible String Int where
    convert s = read s

-- Flexible instances
instance (Convertible a b) => Convertible [a] [b] where
    convert = map convert

-- 8. Phantom Types for Type Safety

-- Phantom type for units
data Unit = Temperature | Length | Mass

newtype Measurement (u :: Unit) = Measurement Double

deriving instance Show (Measurement u)

-- Safe operations
addMeasurements :: Measurement u -> Measurement u -> Measurement u
addMeasurements (Measurement a) (Measurement b) = Measurement (a + b)

-- Can't add different units (won't compile)
-- addTemperatureLength :: Measurement Temperature -> Measurement Length -> Double
-- addTemperatureLength = error "Shouldn't compile"

-- 9. Type Families with Constraints

-- Type family for result type
type family AddResult a b where
    AddResult Int Int = Int
    AddResult Double Double = Double
    AddResult String String = String
    AddResult a b = String

class Addable a b where
    add :: a -> b -> AddResult a b

instance Addable Int Int where
    add = (+)

instance Addable Double Double where
    add = (+)

instance Addable String String where
    add = (++)

-- 10. Kind polymorphism

-- Data type that works on different kinds
data Proxy (a :: k) = Proxy

-- Function that works with any kind
kindDemonstration :: forall k (a :: k). String
kindDemonstration = case (Proxy :: Proxy a) of
                     Proxy -> "Working with kind: " ++ show (typeRep (Proxy :: Proxy k))

-- Using TypeApplications
typeApplicationExample :: String
typeApplicationExample = show @Int 42

-- 11. Advanced Functor and Monad patterns

-- Functor for type-level programming
newtype Id a = Id { runId :: a }

instance Functor Id where
    fmap f (Id x) = Id (f x)

instance Applicative Id where
    pure = Id
    Id f <*> Id x = Id (f x)

instance Monad Id where
    return = pure
    Id x >>= f = f x

-- 12. Constraint Kinds

-- Function that takes a constraint
withConstraint :: forall a. (Show a, Num a) => a -> String
withConstraint x = show x ++ " is a number"

-- Constraint alias
type NumberConstraint a = (Show a, Num a, Eq a)

processNumber :: forall a. NumberConstraint a => a -> String
processNumber x =
    if x == 0
    then "Zero"
    else "Non-zero: " ++ show x

-- 13. Type-level Programming with GHC.TypeLits

-- Type-level strings and symbols
data Symbol

-- Using KnownSymbol
symbolExample :: forall s. KnownSymbol s => Proxy s -> String
symbolExample _ = symbolVal (Proxy :: Proxy s)

-- 14. Template Haskell (simple example)

-- Note: Template Haskell requires additional imports and compiler flags

-- 15. Type Families for Database Schema

-- Type-level database representation
data Field = IntField | StringField | BoolField

type family FieldType (f :: Field) :: Type
type instance FieldType IntField = Int
type instance FieldType StringField = String
type instance FieldType BoolField = Bool

-- Type-safe record
data Record (schema :: [(Symbol, Field)]) where
    Nil :: Record '[]
    Cons :: KnownSymbol name => Proxy name -> FieldType field -> Record rest -> Record '( '(name, field) ': rest)

-- 16. Advanced Pattern Matching on Types

-- Type class for type-level pattern matching
class TypeMatch a where
    type Result a
    match :: a -> Result a

instance TypeMatch Int where
    type Result Int = String
    match = show

instance TypeMatch Bool where
    type Result Bool = String
    match = show

-- 17. Type-level Computation

-- Compute factorial at type level
type family Factorial (n :: Nat) :: Nat where
    Factorial 0 = 1
    Factorial n = n * Factorial (n - 1)

-- 18. Newtype patterns for performance

-- Strict newtype for performance
newtype StrictList a = StrictList [a]

deriving instance Show a => Show (StrictList a)

unpackStrictList :: StrictList a -> [a]
unpackStrictList (StrictList xs) = xs

-- 19. Type classes for mathematical structures

-- Monoid type class
class Monoid m where
    mempty :: m
    mappend :: m -> m -> m
    mconcat :: [m] -> m
    mconcat = foldr mappend mempty

instance Monoid [a] where
    mempty = []
    mappend = (++)

instance Monoid String where
    mempty = ""
    mappend = (++)

-- 20. Type-level state machines

-- Type-level states
data State = Locked | Unlocked

-- Type-safe door
data Door (s :: State) where
    MkDoor :: Door s

lock :: Door 'Unlocked -> Door 'Locked
lock MkDoor = MkDoor

unlock :: Door 'Locked -> Door 'Unlocked
unlock MkDoor = MkDoor

-- This won't compile:
-- unlockDoorTwice = unlock (unlock lockedDoor)

-- Main function demonstrating advanced type system features
main :: IO ()
main = do
    putStrLn "=== Haskell Advanced Type System Examples ==="

    -- Type families
    putStrLn "\n1. Type families:"
    let intList = [1,2,3] :: [Int]
    let maybeInt = Just 42 :: Maybe Int
    print $ length intList
    print $ length maybeInt

    -- GADTs
    putStrLn "\n2. GADTs:"
    let expr1 = Add (I 5) (Mul (I 2) (I 3))
    let expr2 = If (Eq (I 4) (I 5)) (I 1) (I 0)
    putStrLn $ "expr1 = " ++ show (eval expr1)
    putStrLn $ "expr2 = " ++ show (eval expr2)

    -- Data Kinds
    putStrLn "\n3. Data Kinds:"
    putStrLn $ "Head of HList: " ++ show (hhead exampleList)

    -- TypeLits
    putStrLn "\n4. TypeLits:"
    let vec123 = 1 VCons 2 VCons 3 VCons VNil
    print $ vhead vec123

    -- Existential types
    putStrLn "\n5. Existential types:"
    putStrLn $ "Boxes: " ++ show boxes

    -- Phantom types
    putStrLn "\n6. Phantom types:"
    let temp1 = Measurement 25.5 :: Measurement Temperature
    let temp2 = Measurement 30.0 :: Measurement Temperature
    let totalTemp = addMeasurements temp1 temp2
    putStrLn $ "Total temperature: " ++ show totalTemp

    -- Type-level functions
    putStrLn "\n7. Type-level operations:"
    print $ withConstraint @Int 42
    print $ processNumber @Double 3.14

    -- Newtype patterns
    putStrLn "\n8. Newtype patterns:"
    let strictList = StrictList [1,2,3,4,5]
    putStrLn $ "Strict list: " ++ show strictList

    putStrLn "\n=== Advanced Type System Examples Complete! ==="