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

import Control.Monad
import Data.Bifunctor
import Data.Eq.Deriving (deriveEq1)
import Data.Foldable
import Data.Ord.Deriving (deriveOrd1)
import Data.String
import Text.Show.Deriving (deriveShow1)

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 (Type v -> Type v -> Bool
(Type v -> Type v -> Bool)
-> (Type v -> Type v -> Bool) -> Eq (Type v)
forall v. Eq v => Type v -> Type v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type v -> Type v -> Bool
$c/= :: forall v. Eq v => Type v -> Type v -> Bool
== :: Type v -> Type v -> Bool
$c== :: forall v. Eq v => Type v -> Type v -> Bool
Eq, Eq (Type v)
Eq (Type v)
-> (Type v -> Type v -> Ordering)
-> (Type v -> Type v -> Bool)
-> (Type v -> Type v -> Bool)
-> (Type v -> Type v -> Bool)
-> (Type v -> Type v -> Bool)
-> (Type v -> Type v -> Type v)
-> (Type v -> Type v -> Type v)
-> Ord (Type v)
Type v -> Type v -> Bool
Type v -> Type v -> Ordering
Type v -> Type v -> Type v
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall v. Ord v => Eq (Type v)
forall v. Ord v => Type v -> Type v -> Bool
forall v. Ord v => Type v -> Type v -> Ordering
forall v. Ord v => Type v -> Type v -> Type v
min :: Type v -> Type v -> Type v
$cmin :: forall v. Ord v => Type v -> Type v -> Type v
max :: Type v -> Type v -> Type v
$cmax :: forall v. Ord v => Type v -> Type v -> Type v
>= :: Type v -> Type v -> Bool
$c>= :: forall v. Ord v => Type v -> Type v -> Bool
> :: Type v -> Type v -> Bool
$c> :: forall v. Ord v => Type v -> Type v -> Bool
<= :: Type v -> Type v -> Bool
$c<= :: forall v. Ord v => Type v -> Type v -> Bool
< :: Type v -> Type v -> Bool
$c< :: forall v. Ord v => Type v -> Type v -> Bool
compare :: Type v -> Type v -> Ordering
$ccompare :: forall v. Ord v => Type v -> Type v -> Ordering
$cp1Ord :: forall v. Ord v => Eq (Type v)
Ord, Int -> Type v -> ShowS
[Type v] -> ShowS
Type v -> String
(Int -> Type v -> ShowS)
-> (Type v -> String) -> ([Type v] -> ShowS) -> Show (Type v)
forall v. Show v => Int -> Type v -> ShowS
forall v. Show v => [Type v] -> ShowS
forall v. Show v => Type v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type v] -> ShowS
$cshowList :: forall v. Show v => [Type v] -> ShowS
show :: Type v -> String
$cshow :: forall v. Show v => Type v -> String
showsPrec :: Int -> Type v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> Type v -> ShowS
Show, a -> Type b -> Type a
(a -> b) -> Type a -> Type b
(forall a b. (a -> b) -> Type a -> Type b)
-> (forall a b. a -> Type b -> Type a) -> Functor Type
forall a b. a -> Type b -> Type a
forall a b. (a -> b) -> Type a -> Type b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Type b -> Type a
$c<$ :: forall a b. a -> Type b -> Type a
fmap :: (a -> b) -> Type a -> Type b
$cfmap :: forall a b. (a -> b) -> Type a -> Type b
Functor, Type a -> Bool
(a -> m) -> Type a -> m
(a -> b -> b) -> b -> Type a -> b
(forall m. Monoid m => Type m -> m)
-> (forall m a. Monoid m => (a -> m) -> Type a -> m)
-> (forall m a. Monoid m => (a -> m) -> Type a -> m)
-> (forall a b. (a -> b -> b) -> b -> Type a -> b)
-> (forall a b. (a -> b -> b) -> b -> Type a -> b)
-> (forall b a. (b -> a -> b) -> b -> Type a -> b)
-> (forall b a. (b -> a -> b) -> b -> Type a -> b)
-> (forall a. (a -> a -> a) -> Type a -> a)
-> (forall a. (a -> a -> a) -> Type a -> a)
-> (forall a. Type a -> [a])
-> (forall a. Type a -> Bool)
-> (forall a. Type a -> Int)
-> (forall a. Eq a => a -> Type a -> Bool)
-> (forall a. Ord a => Type a -> a)
-> (forall a. Ord a => Type a -> a)
-> (forall a. Num a => Type a -> a)
-> (forall a. Num a => Type a -> a)
-> Foldable Type
forall a. Eq a => a -> Type a -> Bool
forall a. Num a => Type a -> a
forall a. Ord a => Type a -> a
forall m. Monoid m => Type m -> m
forall a. Type a -> Bool
forall a. Type a -> Int
forall a. Type a -> [a]
forall a. (a -> a -> a) -> Type a -> a
forall m a. Monoid m => (a -> m) -> Type a -> m
forall b a. (b -> a -> b) -> b -> Type a -> b
forall a b. (a -> b -> b) -> b -> Type a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Type a -> a
$cproduct :: forall a. Num a => Type a -> a
sum :: Type a -> a
$csum :: forall a. Num a => Type a -> a
minimum :: Type a -> a
$cminimum :: forall a. Ord a => Type a -> a
maximum :: Type a -> a
$cmaximum :: forall a. Ord a => Type a -> a
elem :: a -> Type a -> Bool
$celem :: forall a. Eq a => a -> Type a -> Bool
length :: Type a -> Int
$clength :: forall a. Type a -> Int
null :: Type a -> Bool
$cnull :: forall a. Type a -> Bool
toList :: Type a -> [a]
$ctoList :: forall a. Type a -> [a]
foldl1 :: (a -> a -> a) -> Type a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Type a -> a
foldr1 :: (a -> a -> a) -> Type a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Type a -> a
foldl' :: (b -> a -> b) -> b -> Type a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Type a -> b
foldl :: (b -> a -> b) -> b -> Type a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Type a -> b
foldr' :: (a -> b -> b) -> b -> Type a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Type a -> b
foldr :: (a -> b -> b) -> b -> Type a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Type a -> b
foldMap' :: (a -> m) -> Type a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Type a -> m
foldMap :: (a -> m) -> Type a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Type a -> m
fold :: Type m -> m
$cfold :: forall m. Monoid m => Type m -> m
Foldable, Functor Type
Foldable Type
Functor Type
-> Foldable Type
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Type a -> f (Type b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Type (f a) -> f (Type a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Type a -> m (Type b))
-> (forall (m :: * -> *) a. Monad m => Type (m a) -> m (Type a))
-> Traversable Type
(a -> f b) -> Type a -> f (Type b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Type (m a) -> m (Type a)
forall (f :: * -> *) a. Applicative f => Type (f a) -> f (Type a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Type a -> m (Type b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Type a -> f (Type b)
sequence :: Type (m a) -> m (Type a)
$csequence :: forall (m :: * -> *) a. Monad m => Type (m a) -> m (Type a)
mapM :: (a -> m b) -> Type a -> m (Type b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Type a -> m (Type b)
sequenceA :: Type (f a) -> f (Type a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Type (f a) -> f (Type a)
traverse :: (a -> f b) -> Type a -> f (Type b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Type a -> f (Type b)
$cp2Traversable :: Foldable Type
$cp1Traversable :: Functor Type
Traversable)

deriveEq1 ''Type
deriveOrd1 ''Type
deriveShow1 ''Type

instance Applicative Type where
  pure :: a -> Type a
pure = a -> Type a
forall a. a -> Type a
Var
  <*> :: Type (a -> b) -> Type a -> Type b
(<*>) = Type (a -> b) -> Type a -> Type b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Type where
  >>= :: Type a -> (a -> Type b) -> Type b
(>>=) =
    ((a -> Type b) -> Type a -> Type b)
-> Type a -> (a -> Type b) -> Type b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> Type b) -> Type a -> Type b)
 -> Type a -> (a -> Type b) -> Type b)
-> ((a -> Type b) -> Type a -> Type b)
-> Type a
-> (a -> Type b)
-> Type b
forall a b. (a -> b) -> a -> b
$ (Qualified -> Type b) -> (a -> Type b) -> Type a -> Type b
forall v' v.
(Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind Qualified -> Type b
forall v. Qualified -> Type v
Global

bind :: (Name.Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind :: (Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind Qualified -> Type v'
global v -> Type v'
var Type v
type_ =
  case Type v
type_ of
    Var v
v ->
      v -> Type v'
var v
v

    Global Qualified
g ->
      Qualified -> Type v'
global Qualified
g

    App Type v
t1 Type v
t2 ->
      Type v' -> Type v' -> Type v'
forall v. Type v -> Type v -> Type v
App ((Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
forall v' v.
(Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind Qualified -> Type v'
global v -> Type v'
var Type v
t1) ((Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
forall v' v.
(Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind Qualified -> Type v'
global v -> Type v'
var Type v
t2)

    Fun Type v
t1 Type v
t2 ->
      Type v' -> Type v' -> Type v'
forall v. Type v -> Type v -> Type v
Fun ((Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
forall v' v.
(Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind Qualified -> Type v'
global v -> Type v'
var Type v
t1) ((Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
forall v' v.
(Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind Qualified -> Type v'
global v -> Type v'
var Type v
t2)

    Record [(Field, Type v)]
fields ->
      [(Field, Type v')] -> Type v'
forall v. [(Field, Type v)] -> Type v
Record ([(Field, Type v')] -> Type v') -> [(Field, Type v')] -> Type v'
forall a b. (a -> b) -> a -> b
$ (Type v -> Type v') -> (Field, Type v) -> (Field, Type v')
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
forall v' v.
(Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v'
bind Qualified -> Type v'
global v -> Type v'
var) ((Field, Type v) -> (Field, Type v'))
-> [(Field, Type v)] -> [(Field, Type v')]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Field, Type v)]
fields

instance IsString (Type v) where
  fromString :: String -> Type v
fromString = Qualified -> Type v
forall v. Qualified -> Type v
Global (Qualified -> Type v) -> (String -> Qualified) -> String -> Type v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Qualified
forall a. IsString a => String -> a
fromString

apps :: Type v -> [Type v] -> Type v
apps :: Type v -> [Type v] -> Type v
apps = (Type v -> Type v -> Type v) -> Type v -> [Type v] -> Type v
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type v -> Type v -> Type v
forall v. Type v -> Type v -> Type v
App

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

        Type v
_ ->
          (Type v
typ, [Type v]
args)

funs :: [Type v] -> Type v -> Type v
funs :: [Type v] -> Type v -> Type v
funs [Type v]
args Type v
ret =
  (Type v -> Type v -> Type v) -> Type v -> [Type v] -> Type v
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type v -> Type v -> Type v
forall v. Type v -> Type v -> Type v
Fun Type v
ret [Type v]
args

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

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

    Global Qualified
qname ->
      Qualified -> m
f Qualified
qname

    App Type v
t1 Type v
t2 ->
      (Qualified -> m) -> Type v -> m
forall m v. Monoid m => (Qualified -> m) -> Type v -> m
foldMapGlobals Qualified -> m
f Type v
t1 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Qualified -> m) -> Type v -> m
forall m v. Monoid m => (Qualified -> m) -> Type v -> m
foldMapGlobals Qualified -> m
f Type v
t2

    Fun Type v
t1 Type v
t2 ->
      (Qualified -> m) -> Type v -> m
forall m v. Monoid m => (Qualified -> m) -> Type v -> m
foldMapGlobals Qualified -> m
f Type v
t1 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Qualified -> m) -> Type v -> m
forall m v. Monoid m => (Qualified -> m) -> Type v -> m
foldMapGlobals Qualified -> m
f Type v
t2

    Record [(Field, Type v)]
fields ->
      ((Field, Type v) -> m) -> [(Field, Type v)] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Type v -> m) -> (Field, Type v) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Qualified -> m) -> Type v -> m
forall m v. Monoid m => (Qualified -> m) -> Type v -> m
foldMapGlobals Qualified -> m
f)) [(Field, Type v)]
fields