-- | A DSL for constructing Hydra types

{-# LANGUAGE FlexibleInstances #-} -- TODO: temporary, for IsString (Type)
module Hydra.Dsl.Types where

import Hydra.Constants
import Hydra.Core

import qualified Data.List as L
import qualified Data.Map as M
import Data.String(IsString(..))


instance IsString (Type) where fromString :: String -> Type
fromString = String -> Type
var

-- Not available: := ::=
infixr 0 >:
(>:) :: String -> Type -> FieldType
String
n >: :: String -> Type -> FieldType
>: Type
t = String -> Type -> FieldType
field String
n Type
t

--(::=) :: String -> Type -> FieldType
String
n <=> :: String -> Type -> FieldType
<=> Type
t = String -> Type -> FieldType
field String
n Type
t



infixr 0 -->
(-->) :: Type -> Type -> Type
Type
a --> :: Type -> Type -> Type
--> Type
b = Type -> Type -> Type
function Type
a Type
b

-- Two alternative symbols for type application
(@@) :: Type -> Type -> Type
Type
f @@ :: Type -> Type -> Type
@@ Type
x = Type -> Type -> Type
apply Type
f Type
x
($$) :: Type -> Type -> Type
Type
f $$ :: Type -> Type -> Type
$$ Type
x = Type -> Type -> Type
apply Type
f Type
x

annot :: M.Map Name Term -> Type -> Type
annot :: Map Name Term -> Type -> Type
annot Map Name Term
ann Type
t = AnnotatedType -> Type
TypeAnnotated (AnnotatedType -> Type) -> AnnotatedType -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Map Name Term -> AnnotatedType
AnnotatedType Type
t Map Name Term
ann

apply :: Type -> Type -> Type
apply :: Type -> Type -> Type
apply Type
lhs Type
rhs = ApplicationType -> Type
TypeApplication (Type -> Type -> ApplicationType
ApplicationType Type
lhs Type
rhs)

applyN :: [Type] -> Type
applyN :: [Type] -> Type
applyN [Type]
ts = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
apply ([Type] -> Type
forall a. HasCallStack => [a] -> a
L.head [Type]
ts) ([Type] -> [Type]
forall a. HasCallStack => [a] -> [a]
L.tail [Type]
ts)

bigfloat :: Type
bigfloat :: Type
bigfloat = FloatType -> Type
float FloatType
FloatTypeBigfloat

bigint :: Type
bigint :: Type
bigint = IntegerType -> Type
integer IntegerType
IntegerTypeBigint

binary :: Type
binary :: Type
binary = LiteralType -> Type
literal LiteralType
LiteralTypeBinary

boolean :: Type
boolean :: Type
boolean = LiteralType -> Type
literal LiteralType
LiteralTypeBoolean

enum :: [String] -> Type
enum :: [String] -> Type
enum [String]
names = [FieldType] -> Type
union ([FieldType] -> Type) -> [FieldType] -> Type
forall a b. (a -> b) -> a -> b
$ (String -> Type -> FieldType
`field` Type
unit) (String -> FieldType) -> [String] -> [FieldType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
names

field :: String -> Type -> FieldType
field :: String -> Type -> FieldType
field String
fn = Name -> Type -> FieldType
FieldType (String -> Name
Name String
fn)

fieldsToMap :: [FieldType] -> M.Map Name (Type)
fieldsToMap :: [FieldType] -> Map Name Type
fieldsToMap [FieldType]
fields = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> [(Name, Type)] -> Map Name Type
forall a b. (a -> b) -> a -> b
$ (\(FieldType Name
name Type
typ) -> (Name
name, Type
typ)) (FieldType -> (Name, Type)) -> [FieldType] -> [(Name, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldType]
fields

float32 :: Type
float32 :: Type
float32 = FloatType -> Type
float FloatType
FloatTypeFloat32

float64 :: Type
float64 :: Type
float64 = FloatType -> Type
float FloatType
FloatTypeFloat64

float :: FloatType -> Type
float :: FloatType -> Type
float = LiteralType -> Type
literal (LiteralType -> Type)
-> (FloatType -> LiteralType) -> FloatType -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FloatType -> LiteralType
LiteralTypeFloat

function :: Type -> Type -> Type
function :: Type -> Type -> Type
function Type
dom Type
cod = FunctionType -> Type
TypeFunction (FunctionType -> Type) -> FunctionType -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> FunctionType
FunctionType Type
dom Type
cod

functionN :: [Type] -> Type
functionN :: [Type] -> Type
functionN [Type]
ts = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Type
cod Type
dom -> Type -> Type -> Type
function Type
dom Type
cod) ([Type] -> Type
forall a. HasCallStack => [a] -> a
L.head [Type]
r) ([Type] -> [Type]
forall a. HasCallStack => [a] -> [a]
L.tail [Type]
r)
  where
    r :: [Type]
r = [Type] -> [Type]
forall a. [a] -> [a]
L.reverse [Type]
ts

int16 :: Type
int16 :: Type
int16 = IntegerType -> Type
integer IntegerType
IntegerTypeInt16

int32 :: Type
int32 :: Type
int32 = IntegerType -> Type
integer IntegerType
IntegerTypeInt32

int64 :: Type
int64 :: Type
int64 = IntegerType -> Type
integer IntegerType
IntegerTypeInt64

int8 :: Type
int8 :: Type
int8 = IntegerType -> Type
integer IntegerType
IntegerTypeInt8

integer :: IntegerType -> Type
integer :: IntegerType -> Type
integer = LiteralType -> Type
literal (LiteralType -> Type)
-> (IntegerType -> LiteralType) -> IntegerType -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntegerType -> LiteralType
LiteralTypeInteger

lambda :: String -> Type -> Type
lambda :: String -> Type -> Type
lambda String
v Type
body = LambdaType -> Type
TypeLambda (LambdaType -> Type) -> LambdaType -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type -> LambdaType
LambdaType (String -> Name
Name String
v) Type
body

lambdas :: [String] -> Type -> Type
lambdas :: [String] -> Type -> Type
lambdas [String]
vs Type
body = (String -> Type -> Type) -> Type -> [String] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr String -> Type -> Type
lambda Type
body [String]
vs

list :: Type -> Type
list :: Type -> Type
list = Type -> Type
TypeList

literal :: LiteralType -> Type
literal :: LiteralType -> Type
literal = LiteralType -> Type
TypeLiteral

map :: Type -> Type -> Type
map :: Type -> Type -> Type
map Type
kt Type
vt = MapType -> Type
TypeMap (MapType -> Type) -> MapType -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> MapType
MapType Type
kt Type
vt

mono :: Type -> TypeScheme
mono :: Type -> TypeScheme
mono = [Name] -> Type -> TypeScheme
TypeScheme []

optional :: Type -> Type
optional :: Type -> Type
optional = Type -> Type
TypeOptional

pair :: Type -> Type -> Type
pair :: Type -> Type -> Type
pair Type
a Type
b = [Type] -> Type
TypeProduct [Type
a, Type
b]

poly :: [String] -> Type -> TypeScheme
poly :: [String] -> Type -> TypeScheme
poly [String]
vs Type
t = [Name] -> Type -> TypeScheme
TypeScheme (String -> Name
Name (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
vs) Type
t

product :: [Type] -> Type
product :: [Type] -> Type
product = [Type] -> Type
TypeProduct

record :: [FieldType] -> Type
record :: [FieldType] -> Type
record [FieldType]
fields = RowType -> Type
TypeRecord (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ Name -> [FieldType] -> RowType
RowType Name
placeholderName [FieldType]
fields

scheme :: [String] -> Type -> TypeScheme
scheme :: [String] -> Type -> TypeScheme
scheme [String]
vars Type
body = [Name] -> Type -> TypeScheme
TypeScheme (String -> Name
Name (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
vars) Type
body

set :: Type -> Type
set :: Type -> Type
set = Type -> Type
TypeSet

string :: Type
string :: Type
string = LiteralType -> Type
literal LiteralType
LiteralTypeString

sum :: [Type] -> Type
sum :: [Type] -> Type
sum = [Type] -> Type
TypeSum

uint16 :: Type
uint16 :: Type
uint16 = IntegerType -> Type
integer IntegerType
IntegerTypeUint16

uint32 :: Type
uint32 :: Type
uint32 = IntegerType -> Type
integer IntegerType
IntegerTypeUint32

uint64 :: Type
uint64 :: Type
uint64 = IntegerType -> Type
integer IntegerType
IntegerTypeUint64

uint8 :: Type
uint8 :: Type
uint8 = IntegerType -> Type
integer IntegerType
IntegerTypeUint8

union :: [FieldType] -> Type
union :: [FieldType] -> Type
union [FieldType]
fields = RowType -> Type
TypeUnion (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ Name -> [FieldType] -> RowType
RowType Name
placeholderName [FieldType]
fields

unit :: Type
unit :: Type
unit = RowType -> Type
TypeRecord (RowType -> Type) -> RowType -> Type
forall a b. (a -> b) -> a -> b
$ Name -> [FieldType] -> RowType
RowType (String -> Name
Name String
"hydra/core.Unit") []

var :: String -> Type
var :: String -> Type
var = Name -> Type
TypeVariable (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Name

wrap :: Type -> Type
wrap :: Type -> Type
wrap = Name -> Type -> Type
wrapWithName Name
placeholderName

wrapWithName :: Name -> Type -> Type
wrapWithName :: Name -> Type -> Type
wrapWithName Name
name Type
t = WrappedType -> Type
TypeWrap (WrappedType -> Type) -> WrappedType -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type -> WrappedType
WrappedType Name
name Type
t