-- | A DSL for constructing Hydra terms

{-# LANGUAGE FlexibleInstances #-} -- TODO: temporary, for IsString Term
module Hydra.Dsl.Terms where

import Hydra.Compute
import Hydra.Constants
import Hydra.Core
import Hydra.Graph
import qualified Hydra.Dsl.Literals as Literals

import Prelude hiding (map)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y
import qualified Control.Monad as CM
import Data.Int
import Data.String(IsString(..))


instance IsString Term where fromString :: String -> Term
fromString = String -> Term
string

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

--(<$>) :: Term -> Term -> Term
--f <$> x = apply f x

(<.>) :: Term -> Term -> Term
Term
f <.> :: Term -> Term -> Term
<.> Term
g = Term -> Term -> Term
compose Term
f Term
g

infixr 0 >:
(>:) :: String -> Term -> Field
String
n >: :: String -> Term -> Field
>: Term
t = String -> Term -> Field
field String
n Term
t

annot :: M.Map Name Term -> Term -> Term
annot :: Map Name Term -> Term -> Term
annot Map Name Term
ann Term
t = AnnotatedTerm -> Term
TermAnnotated (AnnotatedTerm -> Term) -> AnnotatedTerm -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Map Name Term -> AnnotatedTerm
AnnotatedTerm Term
t Map Name Term
ann

apply :: Term -> Term -> Term
apply :: Term -> Term -> Term
apply Term
func Term
arg = Application -> Term
TermApplication (Application -> Term) -> Application -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Term -> Application
Application Term
func Term
arg

bigfloat :: Double -> Term
bigfloat :: Double -> Term
bigfloat = Literal -> Term
literal (Literal -> Term) -> (Double -> Literal) -> Double -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Literal
Literals.bigfloat

bigint :: Integer -> Term
bigint :: Integer -> Term
bigint = Literal -> Term
literal (Literal -> Term) -> (Integer -> Literal) -> Integer -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Literal
Literals.bigint

binary :: String -> Term
binary :: String -> Term
binary = Literal -> Term
literal (Literal -> Term) -> (String -> Literal) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Literal
Literals.binary

boolean :: Bool -> Term
boolean :: Bool -> Term
boolean = Literal -> Term
literal (Literal -> Term) -> (Bool -> Literal) -> Bool -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Literal
Literals.boolean

compose :: Term -> Term -> Term
compose :: Term -> Term -> Term
compose Term
f Term
g = String -> Term -> Term
lambda String
"x" (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Term -> Term
apply Term
f (Term -> Term -> Term
apply Term
g (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
var String
"x")

constant :: Term -> Term
constant :: Term -> Term
constant = String -> Term -> Term
lambda String
ignoredVariable

elimination :: Elimination -> Term
elimination :: Elimination -> Term
elimination = Function -> Term
TermFunction (Function -> Term)
-> (Elimination -> Function) -> Elimination -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elimination -> Function
FunctionElimination

false :: Term
false :: Term
false = Bool -> Term
boolean Bool
False

field :: String -> Term -> Field
field :: String -> Term -> Field
field String
n = Name -> Term -> Field
Field (String -> Name
Name String
n)

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

first :: Term
first :: Term
first = Int -> Int -> Term
untuple Int
2 Int
0

float32 :: Float -> Term
float32 :: Float -> Term
float32 = Literal -> Term
literal (Literal -> Term) -> (Float -> Literal) -> Float -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Literal
Literals.float32

float64 :: Double -> Term
float64 :: Double -> Term
float64 = Literal -> Term
literal (Literal -> Term) -> (Double -> Literal) -> Double -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Literal
Literals.float64

float :: FloatValue -> Term
float :: FloatValue -> Term
float = Literal -> Term
literal (Literal -> Term) -> (FloatValue -> Literal) -> FloatValue -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FloatValue -> Literal
Literals.float

fold :: Term -> Term
fold :: Term -> Term
fold = Function -> Term
TermFunction (Function -> Term) -> (Term -> Function) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elimination -> Function
FunctionElimination (Elimination -> Function)
-> (Term -> Elimination) -> Term -> Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Elimination
EliminationList

identity :: Term
identity :: Term
identity = String -> Term -> Term
lambda String
"x" (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term
var String
"x"

inject :: Name -> Field -> Term
inject :: Name -> Field -> Term
inject Name
tname = Injection -> Term
TermUnion (Injection -> Term) -> (Field -> Injection) -> Field -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Field -> Injection
Injection Name
tname

int16 :: Int16 -> Term
int16 :: Int16 -> Term
int16 = Literal -> Term
literal (Literal -> Term) -> (Int16 -> Literal) -> Int16 -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Literal
Literals.int16

int32 :: Int -> Term
int32 :: Int -> Term
int32 = Literal -> Term
literal (Literal -> Term) -> (Int -> Literal) -> Int -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Literal
Literals.int32

int64 :: Int64 -> Term
int64 :: Int64 -> Term
int64 = Literal -> Term
literal (Literal -> Term) -> (Int64 -> Literal) -> Int64 -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Literal
Literals.int64

int8 :: Int8 -> Term
int8 :: Int8 -> Term
int8 = Literal -> Term
literal (Literal -> Term) -> (Int8 -> Literal) -> Int8 -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Literal
Literals.int8

integer :: IntegerValue -> Term
integer :: IntegerValue -> Term
integer = Literal -> Term
literal (Literal -> Term)
-> (IntegerValue -> Literal) -> IntegerValue -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntegerValue -> Literal
Literals.integer

just :: Term -> Term
just :: Term -> Term
just = Maybe Term -> Term
optional (Maybe Term -> Term) -> (Term -> Maybe Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Maybe Term
forall a. a -> Maybe a
Just

lambda :: String -> Term -> Term
lambda :: String -> Term -> Term
lambda String
param Term
body = Function -> Term
TermFunction (Function -> Term) -> Function -> Term
forall a b. (a -> b) -> a -> b
$ Lambda -> Function
FunctionLambda (Lambda -> Function) -> Lambda -> Function
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Type -> Term -> Lambda
Lambda (String -> Name
Name String
param) Maybe Type
forall a. Maybe a
Nothing Term
body

letMulti :: [(String, Term)] -> Term -> Term
letMulti :: [(String, Term)] -> Term -> Term
letMulti [(String, Term)]
bindings Term
body = Let -> Term
TermLet (Let -> Term) -> Let -> Term
forall a b. (a -> b) -> a -> b
$ [LetBinding] -> Term -> Let
Let ((String, Term) -> LetBinding
toBinding ((String, Term) -> LetBinding) -> [(String, Term)] -> [LetBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Term)]
bindings) Term
body
  where
    toBinding :: (String, Term) -> LetBinding
toBinding (String
name, Term
term) = Name -> Term -> Maybe TypeScheme -> LetBinding
LetBinding (String -> Name
Name String
name) Term
term Maybe TypeScheme
forall a. Maybe a
Nothing

-- Construct a 'let' term with a single binding
letTerm :: Name -> Term -> Term -> Term
letTerm :: Name -> Term -> Term -> Term
letTerm Name
v Term
t1 Term
t2 = Let -> Term
TermLet (Let -> Term) -> Let -> Term
forall a b. (a -> b) -> a -> b
$ [LetBinding] -> Term -> Let
Let [Name -> Term -> Maybe TypeScheme -> LetBinding
LetBinding Name
v Term
t1 Maybe TypeScheme
forall a. Maybe a
Nothing] Term
t2

list :: [Term] -> Term
list :: [Term] -> Term
list = [Term] -> Term
TermList

literal :: Literal -> Term
literal :: Literal -> Term
literal = Literal -> Term
TermLiteral

map :: M.Map Term Term -> Term
map :: Map Term Term -> Term
map = Map Term Term -> Term
TermMap

mapTerm :: M.Map Term Term -> Term
mapTerm :: Map Term Term -> Term
mapTerm = Map Term Term -> Term
TermMap

match :: Name -> Maybe Term -> [Field] -> Term
match :: Name -> Maybe Term -> [Field] -> Term
match Name
tname Maybe Term
def [Field]
fields = Function -> Term
TermFunction (Function -> Term) -> Function -> Term
forall a b. (a -> b) -> a -> b
$ Elimination -> Function
FunctionElimination (Elimination -> Function) -> Elimination -> Function
forall a b. (a -> b) -> a -> b
$ CaseStatement -> Elimination
EliminationUnion (CaseStatement -> Elimination) -> CaseStatement -> Elimination
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Term -> [Field] -> CaseStatement
CaseStatement Name
tname Maybe Term
def [Field]
fields

matchOpt :: Term -> Term -> Term
matchOpt :: Term -> Term -> Term
matchOpt Term
n Term
j = Function -> Term
TermFunction (Function -> Term) -> Function -> Term
forall a b. (a -> b) -> a -> b
$ Elimination -> Function
FunctionElimination (Elimination -> Function) -> Elimination -> Function
forall a b. (a -> b) -> a -> b
$ OptionalCases -> Elimination
EliminationOptional (OptionalCases -> Elimination) -> OptionalCases -> Elimination
forall a b. (a -> b) -> a -> b
$ Term -> Term -> OptionalCases
OptionalCases Term
n Term
j

matchWithVariants :: Name -> Maybe Term -> [(Name, Name)] -> Term
matchWithVariants :: Name -> Maybe Term -> [(Name, Name)] -> Term
matchWithVariants Name
tname Maybe Term
def [(Name, Name)]
pairs = Name -> Maybe Term -> [Field] -> Term
match Name
tname Maybe Term
def ((Name, Name) -> Field
toField ((Name, Name) -> Field) -> [(Name, Name)] -> [Field]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
pairs)
  where
    toField :: (Name, Name) -> Field
toField (Name
from, Name
to) = Name -> Term -> Field
Field Name
from (Term -> Field) -> Term -> Field
forall a b. (a -> b) -> a -> b
$ Term -> Term
constant (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Term
unitVariant Name
tname Name
to

nothing :: Term
nothing :: Term
nothing = Maybe Term -> Term
optional Maybe Term
forall a. Maybe a
Nothing

optional :: Y.Maybe Term -> Term
optional :: Maybe Term -> Term
optional = Maybe Term -> Term
TermOptional

pair :: Term -> Term -> Term
pair :: Term -> Term -> Term
pair Term
a Term
b = [Term] -> Term
TermProduct [Term
a, Term
b]

primitive :: Name -> Term
primitive :: Name -> Term
primitive = Function -> Term
TermFunction (Function -> Term) -> (Name -> Function) -> Name -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Function
FunctionPrimitive

product :: [Term] -> Term
product :: [Term] -> Term
product = [Term] -> Term
TermProduct

project :: Name -> Name -> Term
project :: Name -> Name -> Term
project Name
tname Name
fname = Function -> Term
TermFunction (Function -> Term) -> Function -> Term
forall a b. (a -> b) -> a -> b
$ Elimination -> Function
FunctionElimination (Elimination -> Function) -> Elimination -> Function
forall a b. (a -> b) -> a -> b
$ Projection -> Elimination
EliminationRecord (Projection -> Elimination) -> Projection -> Elimination
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Projection
Projection Name
tname Name
fname

record :: Name -> [Field] -> Term
record :: Name -> [Field] -> Term
record Name
tname [Field]
fields = Record -> Term
TermRecord (Record -> Term) -> Record -> Term
forall a b. (a -> b) -> a -> b
$ Name -> [Field] -> Record
Record Name
tname [Field]
fields

second :: Term
second :: Term
second = Int -> Int -> Term
untuple Int
2 Int
1

set :: S.Set Term -> Term
set :: Set Term -> Term
set = Set Term -> Term
TermSet

string :: String -> Term
string :: String -> Term
string = Literal -> Term
TermLiteral (Literal -> Term) -> (String -> Literal) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Literal
LiteralString

sum :: Int -> Int -> Term -> Term
sum :: Int -> Int -> Term -> Term
sum Int
i Int
s Term
term = Sum -> Term
TermSum (Sum -> Term) -> Sum -> Term
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Term -> Sum
Sum Int
i Int
s Term
term

true :: Term
true :: Term
true = Bool -> Term
boolean Bool
True

typed :: Type -> Term -> Term
typed :: Type -> Term -> Term
typed Type
typ Term
term = TypedTerm -> Term
TermTyped (TypedTerm -> Term) -> TypedTerm -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Type -> TypedTerm
TypedTerm Term
term Type
typ

uint16 :: Int -> Term
uint16 :: Int -> Term
uint16 = Literal -> Term
literal (Literal -> Term) -> (Int -> Literal) -> Int -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Literal
Literals.uint16

uint32 :: Int64 -> Term
uint32 :: Int64 -> Term
uint32 = Literal -> Term
literal (Literal -> Term) -> (Int64 -> Literal) -> Int64 -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Literal
Literals.uint32

uint64 :: Integer -> Term
uint64 :: Integer -> Term
uint64 = Literal -> Term
literal (Literal -> Term) -> (Integer -> Literal) -> Integer -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Literal
Literals.uint64

uint8 :: Int16 -> Term
uint8 :: Int16 -> Term
uint8 = Literal -> Term
literal (Literal -> Term) -> (Int16 -> Literal) -> Int16 -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Literal
Literals.uint8

unit :: Term
unit :: Term
unit = Record -> Term
TermRecord (Record -> Term) -> Record -> Term
forall a b. (a -> b) -> a -> b
$ Name -> [Field] -> Record
Record Name
_Unit []

unitVariant :: Name -> Name -> Term
unitVariant :: Name -> Name -> Term
unitVariant Name
tname Name
fname = Name -> Name -> Term -> Term
variant Name
tname Name
fname Term
unit

untuple :: Int -> Int -> Term
untuple :: Int -> Int -> Term
untuple Int
arity Int
idx = Function -> Term
TermFunction (Function -> Term) -> Function -> Term
forall a b. (a -> b) -> a -> b
$ Elimination -> Function
FunctionElimination (Elimination -> Function) -> Elimination -> Function
forall a b. (a -> b) -> a -> b
$ TupleProjection -> Elimination
EliminationProduct (TupleProjection -> Elimination) -> TupleProjection -> Elimination
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TupleProjection
TupleProjection Int
arity Int
idx

unwrap :: Name -> Term
unwrap :: Name -> Term
unwrap = Function -> Term
TermFunction (Function -> Term) -> (Name -> Function) -> Name -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elimination -> Function
FunctionElimination (Elimination -> Function)
-> (Name -> Elimination) -> Name -> Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Elimination
EliminationWrap

var :: String -> Term
var :: String -> Term
var = Name -> Term
TermVariable (Name -> Term) -> (String -> Name) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Name

variant :: Name -> Name -> Term -> Term
variant :: Name -> Name -> Term -> Term
variant Name
tname Name
fname Term
term = Injection -> Term
TermUnion (Injection -> Term) -> Injection -> Term
forall a b. (a -> b) -> a -> b
$ Name -> Field -> Injection
Injection Name
tname (Field -> Injection) -> Field -> Injection
forall a b. (a -> b) -> a -> b
$ Name -> Term -> Field
Field Name
fname Term
term

with :: Term -> [Field] -> Term
Term
env with :: Term -> [Field] -> Term
`with` [Field]
bindings = Let -> Term
TermLet (Let -> Term) -> Let -> Term
forall a b. (a -> b) -> a -> b
$ [LetBinding] -> Term -> Let
Let (Field -> LetBinding
toBinding (Field -> LetBinding) -> [Field] -> [LetBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field]
bindings) Term
env
  where
     toBinding :: Field -> LetBinding
toBinding (Field Name
name Term
value) = Name -> Term -> Maybe TypeScheme -> LetBinding
LetBinding Name
name Term
value Maybe TypeScheme
forall a. Maybe a
Nothing

withVariant :: Name -> Name -> Term
withVariant :: Name -> Name -> Term
withVariant Name
tname = Term -> Term
constant (Term -> Term) -> (Name -> Term) -> Name -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> Term
unitVariant Name
tname

wrap :: Name -> Term -> Term
wrap :: Name -> Term -> Term
wrap Name
name Term
term = WrappedTerm -> Term
TermWrap (WrappedTerm -> Term) -> WrappedTerm -> Term
forall a b. (a -> b) -> a -> b
$ Name -> Term -> WrappedTerm
WrappedTerm Name
name Term
term