{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE OverloadedStrings #-}
module AST.Utils.Type
  ( delambda
  , dealias
  , deepDealias
  , iteratedDealias
  )
  where


import qualified Data.Map as Map

import AST.Canonical (Type(..), AliasType(..))
import qualified Elm.Name as N



-- DELAMBDA


delambda :: Type -> [Type]
delambda tipe =
  case tipe of
    TLambda arg result ->
      arg : delambda result

    _ ->
      [tipe]



-- DEALIAS


dealias :: [(N.Name, Type)] -> AliasType -> Type
dealias args aliasType =
  case aliasType of
    Holey tipe ->
      dealiasHelp (Map.fromList args) tipe

    Filled tipe ->
      tipe


dealiasHelp :: Map.Map N.Name Type -> Type -> Type
dealiasHelp typeTable tipe =
  case tipe of
    TLambda a b ->
      TLambda
        (dealiasHelp typeTable a)
        (dealiasHelp typeTable b)

    TVar x ->
      Map.findWithDefault tipe x typeTable

    TRecord fields ext ->
      TRecord
        (Map.map (dealiasHelp typeTable) fields)
        (fmap (dealiasHelp typeTable) ext)

    TAlias home name args t' ->
      TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'

    TType home name args ->
      TType home name (map (dealiasHelp typeTable) args)

    TUnit ->
      TUnit

    TTuple a b maybeC ->
      TTuple
        (dealiasHelp typeTable a)
        (dealiasHelp typeTable b)
        (fmap (dealiasHelp typeTable) maybeC)



-- DEEP DEALIAS


deepDealias :: Type -> Type
deepDealias tipe =
  case tipe of
    TLambda a b ->
      TLambda (deepDealias a) (deepDealias b)

    TVar _ ->
      tipe

    TRecord fields ext ->
      TRecord (Map.map deepDealias fields) (fmap deepDealias ext)

    TAlias _ _ args tipe' ->
      deepDealias (dealias args tipe')

    TType home name args ->
      TType home name (map deepDealias args)

    TUnit ->
      TUnit

    TTuple a b c ->
      TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)



-- ITERATED DEALIAS


iteratedDealias :: Type -> Type
iteratedDealias tipe =
  case tipe of
    TAlias _ _ args realType ->
      iteratedDealias (dealias args realType)

    _ ->
      tipe