{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

module Main (main) where

import Control.Monad

import Data.Foldable

import Language.Haskell.TH.Syntax          (Name, lift, mkName)
import Language.Haskell.TH.TypeInterpreter

import System.Exit

import Types

con1 = $(fromName ''Int >>= lift)
con2 = $(fromName ''Maybe >>= lift)

primCon1 = $(fromName ''[] >>= lift)
primCon2 = $(fromName ''(->) >>= lift)

class1 = $(fromName ''Num >>= lift)
class2 = $(fromName ''Class1 >>= lift)

syn1 = $(fromName ''Syn1 >>= lift)
syn2 = $(fromName ''Syn2 >>= lift)
syn3 = $(fromName ''Syn3 >>= lift)
syn4 = $(fromName ''Syn4 >>= lift)
syn5 = $(fromName ''Syn5 >>= lift)
syn6 = $(fromName ''Syn6 >>= lift)
syn7 = $(fromName ''Syn7 >>= lift)
syn8 = $(fromName ''Syn8 >>= lift)
syn9 = $(fromName ''Syn9 >>= lift)
syn10 = $(fromName ''Syn10 >>= lift)
syn11 = $(fromName ''Syn11 >>= lift)
syn12 = $(fromName ''Syn12 >>= lift)
syn13 = $(fromName ''Syn13 >>= lift)
syn14 = $(fromName ''Syn14 >>= lift)
syn15 = $(fromName ''Syn15 >>= lift)
syn16 = $(fromName ''Syn16 >>= lift)
syn17 = $(fromName ''Syn17 >>= lift)

fam1 = $(fromName ''Fam1 >>= lift)
fam2 = $(fromName ''Fam2 >>= lift)
fam3 = $(fromName ''Fam3 >>= lift)
fam4 = $(fromName ''Fam4 >>= lift)
fam5 = $(fromName ''Fam5 >>= lift)
fam6 = $(fromName ''Fam6 >>= lift)
fam7 = $(fromName ''Fam7 >>= lift)

runCase :: TypeExp -> TypeExp -> IO ()
runCase expected actual
    | expected == actual = pure ()
    | otherwise = do
        putStrLn "Mismatch!"
        putStrLn ("Expected: " ++ show expected)
        putStrLn ("Actual:   " ++ show actual)
        exitFailure

matchCase :: TypeExp -> (TypeExp -> Maybe a) -> IO ()
matchCase exp apply
    | Nothing <- apply exp = do
        putStrLn "Mismatch!"
        putStrLn ("Got: " ++ show exp)
        exitFailure

    | otherwise = pure ()

anyName :: Name
anyName = mkName ""

main :: IO ()
main = do
    -- Type constructors
    runCase con1 (Atom (Name ''Int))
    runCase con2 (Atom (Name ''Maybe))

    -- Primitive type constructors
    runCase primCon1 (Atom (Name ''[]))
    runCase primCon2 (Atom (Name ''(->)))

    -- Type classes
    runCase class1 (Atom (Name ''Num))
    runCase class2 (Atom (Name ''Class1))

    -- Type synonyms
    runCase syn1 (Atom (Integer 1337))
    runCase syn2 (Atom (String "Hello"))
    runCase syn3 (Atom (Name ''Char))
    runCase syn4 (Atom (PromotedName 'Nothing))
    runCase syn5 syn2
    runCase syn6 (Apply (Atom (Name ''[])) (Atom (Name ''Char)))
    runCase syn7 (Apply (Apply (Atom (Name ''(,))) syn6) syn3)
    runCase syn8 (Synonym anyName (Variable anyName))
    runCase syn9 (Synonym anyName syn7)
    runCase syn10 (Atom (Name ''Maybe))
    matchCase syn11 $ \ input -> do
        let Synonym p (Apply (Apply (Atom (Name f)) (Variable n)) (Variable m)) = input
        guard (f == ''Either && p == n && n == m)
    runCase syn12 syn3
    runCase syn13 syn2
    runCase syn14 (Apply (Apply fam4 (Atom (Name ''Int))) (Atom (Name ''Word)))
    runCase syn15 (Apply (Apply fam7 (Atom (String "World"))) (Atom (Integer 42)))
    matchCase syn16 $ \ input -> do
        let Synonym p (Apply (Apply f (Variable n)) b) = input
        guard (f == fam4 && p == n && b == syn6)
    runCase syn17 (Family [TypeEquation [syn1] syn4])

    -- Type families
    runCase fam1 (Family [])
    runCase fam2 syn7
    runCase fam3 (Family [])
    runCase fam4 (Family [TypeEquation [syn3, syn7] syn6, TypeEquation [syn7, syn6] syn3])
    runCase fam5 (Family [])
    runCase fam6 syn2
    runCase fam7 (Family [TypeEquation [syn2, syn1] syn4])

{-
    Tests that are missing:

    + Type family
        ?

    + Applications
        ?
-}