Type.hs

{-# language DeriveFoldable #-}
{-# language DeriveFunctor #-}
{-# language DeriveTraversable #-}
{-# language OverloadedStrings #-}
module Language.Elm.Type where

import Protolude hiding (Type)

import Data.String

import qualified Language.Elm.Name as Name

data Type v
  = Var v
  | Global Name.Qualified
  | App (Type v) (Type v)
  | Fun (Type v) (Type v)
  | Record [(Name.Field, Type v)]
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

instance Applicative Type where
  pure = Var
  (<*>) = ap

instance Monad Type where
  Var v >>= f = f v
  Global g >>= _ = Global g
  App t1 t2 >>= f = App (t1 >>= f) (t2 >>= f)
  Fun t1 t2 >>= f = Fun (t1 >>= f) (t2 >>= f)
  Record fields >>= f = Record [(n, t >>= f) | (n, t) <- fields]

instance IsString (Type v) where
  fromString = Global . fromString

apps :: Type v -> [Type v] -> Type v
apps = foldl' App

appsView :: Type v -> (Type v, [Type v])
appsView = go mempty
  where
    go args typ =
      case typ of
        App t1 t2 ->
          go (t2 : args) t1

        _ ->
          (typ, args)

funs :: [Type v] -> Type v -> Type v
funs args ret =
  foldr Fun ret args

tuple :: Type v -> Type v -> Type v
tuple t1 t2 = apps "Basics.," [t1, t2]

foldMapGlobals
  :: Monoid m
  => (Name.Qualified -> m)
  -> Type v
  -> m
foldMapGlobals f type_ =
  case type_ of
    Var _ ->
      mempty

    Global qname ->
      f qname

    App t1 t2 ->
      foldMapGlobals f t1 <> foldMapGlobals f t2

    Fun t1 t2 ->
      foldMapGlobals f t1 <> foldMapGlobals f t2

    Record fields ->
      foldMap (foldMap (foldMapGlobals f)) fields