Phantoms.hs

-- | Term-level DSL which makes use of phantom types. Use this DSL for defining programs as opposed to data type definitions.
-- The phantom types provide static type checking in Haskell prior to Hydra's runtime type checking.
module Hydra.Dsl.Phantoms (
  module Hydra.Dsl.Phantoms,
  module Hydra.Dsl.PhantomLiterals,
) where

import Hydra.Kernel
import Hydra.Dsl.Common
import Hydra.Dsl.PhantomLiterals
import Hydra.Sources.Libraries
import qualified Hydra.Dsl.Annotations as Ann
import qualified Hydra.Dsl.Terms as Terms
import qualified Hydra.Show.Core as ShowCore

import Prelude hiding ((++))
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S


-- * Operators

infixr 0 ~>
(~>) :: String -> TTerm x -> TTerm (a -> b)
name ~> body = lambda name body

infixl 1 <~
(<~) :: String -> TTerm a -> TTerm b -> TTerm b
name <~ value = let1 name value

infixl 1 <<~
(<<~) :: String -> TTerm (Flow s a) -> TTerm (Flow s b) -> TTerm (Flow s b)
name <<~ def = bind name def

-- | Function composition operator: f <.> g creates a function that applies g then f
-- Example: toString <.> increment
(<.>) :: TTerm (b -> c) -> TTerm (a -> b) -> TTerm (a -> c)
f <.> g = compose f g

-- | Function application operator: function @@ argument
-- Example: add @@ int32 1
(@@) :: TTerm (a -> b) -> TTerm a -> TTerm b
fun @@ arg = apply fun arg

-- | Field definition operator for records: name>: value
-- Example: "name">: string "John"
infixr 0 >:
(>:) :: String -> TTerm a -> Field
name>: term = Field (Name name) (unTTerm term)

-- | Field definition operator with pre-constructed name: fname>>: value
-- Example: _Person_name>>: string "John"
infixr 0 >>:
(>>:) :: Name -> TTerm a -> Field
fname >>: d = Field fname (unTTerm d)

-- * Fundamentals

-- | Apply a function to an argument
-- Example: apply (var "add") (int32 1)
apply :: TTerm (a -> b) -> TTerm a -> TTerm b
apply (TTerm lhs) (TTerm rhs) = TTerm $ Terms.apply lhs rhs

let1 :: String -> TTerm a -> TTerm b -> TTerm b
let1 name (TTerm value) (TTerm env) = TTerm $ TermLet $ Let [Binding (Name name) value Nothing] env

-- | Create a let expression with multiple bindings
-- Example: lets ["x">: int32 1, "y">: int32 2] (var "add" @@ var "x" @@ var "y")
lets :: [Field] -> TTerm a -> TTerm a
lets fields (TTerm env) = TTerm $ TermLet $ Let (toBinding <$> fields) env
  where
     toBinding (Field name value) = Binding name value Nothing

-- | Create a variable reference
-- Example: var "x"
var :: String -> TTerm a
var v = TTerm $ Terms.var v

bind :: String -> TTerm (Flow s a) -> TTerm (Flow s b) -> TTerm (Flow s b)
bind v def body = primitive2 _flows_bind def $ lambda v $ body

binds :: [Field] -> TTerm (Flow s a) -> TTerm (Flow s a)
binds fields rhs = L.foldr withField rhs fields
  where
    withField (Field (Name fname) fterm) b = bind fname (TTerm fterm) b

exec :: TTerm (Flow s a) -> TTerm (Flow s b) -> TTerm (Flow s b)
exec f b = primitive2 _flows_bind f (lambda ignoredVariable b)

produce :: TTerm a -> TTerm (Flow s a)
produce = primitive1 _flows_pure

trace :: TTerm String -> TTerm (Flow s a) -> TTerm (Flow s a)
trace msg flow = var "hydra.monads.withTrace" @@ msg @@ flow

-- * Functions

unaryFunction :: (TTerm a -> TTerm b) -> TTerm (a -> b)
unaryFunction f = case (unTTerm $ f $ var "x") of
  TermApplication (Application lhs _) -> TTerm lhs
  TermOptional (Just _) -> primitive _optionals_pure
  TermUnion (Injection tname (Field fname _)) -> lambda "x" $ inject tname fname $ var "x"
  TermWrap (WrappedTerm tname _) -> lambda "x" $ wrap tname $ var "x"

binaryFunction :: (TTerm a -> TTerm b -> TTerm c) -> TTerm (a -> b -> c)
binaryFunction f = case (unTTerm $ f (var "x") (var "y")) of
  TermApplication (Application (TermApplication (Application lhs _)) _) -> TTerm lhs
  t -> TTerm $ Terms.string $ "unexpected term as binary function: " <> ShowCore.term t

-- | Compose two functions (g then f)
-- Example: compose (var "stringLength") (var "toString")
compose :: TTerm (b -> c) -> TTerm (a -> b) -> TTerm (a -> c)
compose (TTerm f) (TTerm g) = TTerm $ Terms.compose f g

-- | Create a constant function that always returns the same value
-- Example: constant true
constant :: TTerm a -> TTerm (b -> a)
constant (TTerm term) = TTerm $ Terms.constant term

-- | Identity function that returns its argument unchanged
-- Example: identity
identity :: TTerm (a -> a)
identity = TTerm Terms.identity

-- | Create a lambda function with one parameter
-- Example: lambda "x" (var "add" @@ var "x" @@ int32 1)
lambda :: String -> TTerm x -> TTerm (a -> b)
lambda v (TTerm body) = TTerm $ Terms.lambda v body

-- | Create a multi-parameter lambda function
-- Example: lambdas ["x", "y"] (add @@ var "x" @@ var "y")
lambdas :: [String] -> TTerm x -> TTerm (a -> b)
lambdas params (TTerm body) = TTerm $ Terms.lambdas params body

-- | Primitive function by name
-- Example: primitive (Name "hydra.lib.strings.length")
primitive :: Name -> TTerm a
primitive = TTerm . Terms.primitive

-- | Apply a primitive function to one argument
-- Example: primitive1 _math_abs (int32 (-5))
primitive1 :: Name -> TTerm a -> TTerm b
primitive1 primName (TTerm a) = TTerm $ Terms.primitive primName Terms.@@ a

-- | Apply a primitive function to two arguments
-- Example: primitive2 _math_add (int32 2) (int32 3)
primitive2 :: Name -> TTerm a -> TTerm b -> TTerm c
primitive2 primName (TTerm a) (TTerm b) = TTerm $ Terms.primitive primName Terms.@@ a Terms.@@ b

-- | Apply a primitive function to three arguments
-- Example: primitive3 _string_replace (string "hello") (string "e") (string "a")
primitive3 :: Name -> TTerm a -> TTerm b -> TTerm c -> TTerm d
primitive3 primName (TTerm a) (TTerm b) (TTerm c) = TTerm $ Terms.primitive primName Terms.@@ a Terms.@@ b Terms.@@ c

-- * Collections

-- | Create a fold function to process lists
-- Example: fold (lambda "acc" (lambda "x" (add @@ var "acc" @@ var "x")))
fold :: TTerm (b -> a -> b) -> TTerm (b -> [a] -> b)
fold f = (primitive _lists_foldl) @@ f

-- | Create a 'Just' optional value
-- Example: just (string "found")
just :: TTerm a -> TTerm (Maybe a)
just (TTerm term) = TTerm $ Terms.just term

-- | Function that wraps a value in 'Just'
-- Example: just_ @@ myValue
just_ :: TTerm (a -> Maybe a)
just_ = TTerm $ Terms.lambda "just_" $ Terms.just $ Terms.var "just_"

-- | Create a list of terms
-- Example: list [int32 1, int32 2, int32 3]
list :: [TTerm a] -> TTerm [a]
list els = TTerm $ Terms.list (unTTerm <$> els)

-- | Create a map/dictionary term
-- Example: map (M.fromList [(string "a", int32 1), (string "b", int32 2)])
map :: M.Map (TTerm a) (TTerm b) -> TTerm (M.Map a b)
map = TTerm . Terms.map . M.fromList . fmap fromTTerm . M.toList
  where
    fromTTerm (TTerm k, TTerm v) = (k, v)

-- | Create a 'Nothing' optional value
-- Example: nothing
nothing :: TTerm (Maybe a)
nothing = TTerm Terms.nothing

-- | Create an optional value from a Maybe
-- Example: opt (Just myValue)
opt :: Maybe (TTerm a) -> TTerm (Maybe a)
opt mc = TTerm $ Terms.optional (unTTerm <$> mc)

-- | Create a set of terms
-- Example: set [string "a", string "b", string "c"]
set :: [TTerm a] -> TTerm (S.Set a)
set = TTerm . Terms.set . S.fromList . fmap unTTerm

-- * Products and tuples

-- | First element projection function for pairs
-- Example: first $ pair (string "foo") (string "bar")
first :: TTerm (a, b) -> TTerm a
first pair = TTerm (Terms.untuple 2 0) @@ pair

-- | Create a pair (2-tuple)
-- Example: pair (string "age") (int32 32)
pair :: (TTerm a) -> (TTerm b) -> TTerm (a, b)
pair (TTerm l) (TTerm r) = TTerm $ Terms.pair l r

-- | Second element projection function for pairs
-- Example: second $ pair (string "foo") (string "bar")
second :: TTerm (a, b) -> TTerm b
second pair = TTerm (Terms.untuple 2 1) @@ pair

triple :: TTerm a -> TTerm b -> TTerm c -> TTerm (a, b, c)
triple (TTerm a) (TTerm b) (TTerm c) = TTerm $ Terms.triple a b c

tuple4 :: TTerm a -> TTerm b -> TTerm c -> TTerm d -> TTerm (a, b, c, d)
tuple4 (TTerm a) (TTerm b) (TTerm c) (TTerm d) = TTerm $ Terms.tuple4 a b c d

tuple5 :: TTerm a -> TTerm b -> TTerm c -> TTerm d -> TTerm e -> TTerm (a, b, c, d, e)
tuple5 (TTerm a) (TTerm b) (TTerm c) (TTerm d) (TTerm e) = TTerm $ Terms.tuple5 a b c d e

-- | Create a tuple projection function
-- Example: untuple 3 1 extracts the second element of a 3-tuple
untuple :: Int -> Int -> TTerm (a -> b)
untuple arity idx = TTerm $ Terms.untuple arity idx

-- * Records, unions and newtypes

-- | Create a field with the given name and value
-- Example: field (Name "age") (int32 30)
field :: Name -> TTerm a -> Field
field fname (TTerm val) = Field fname val

-- | Create a union injection
-- Example: inject (Name "Result") (Name "success") (string "ok")
inject :: Name -> Name -> TTerm a -> TTerm b
inject name fname (TTerm term) = TTerm $ Terms.inject name (Field fname term)

-- | Create a function that injects its argument into a union variant
-- Example: injectLambda (Name "Result") (Name "success")
injectLambda :: Name -> Name -> TTerm (a -> b)
injectLambda name fname = lambda "injected_" $ inject name fname $ var "injected_"

-- | Extract a field from a record
-- Example: project (Name "Person") (Name "name")
project :: Name -> Name -> TTerm (a -> b)
project name fname = TTerm $ Terms.project name fname

-- | Create a record with named fields
-- Example: record (Name "Person") [field (Name "name") (string "John"), field (Name "age") (int32 30)]
record :: Name -> [Field] -> TTerm a
record name fields = TTerm $ Terms.record name fields

-- | Unit value (empty record)
unit :: TTerm a
unit = TTerm Terms.unit

-- | Create a unit variant of a union
-- Example: unitVariant (Name "Result") (Name "success")
unitVariant :: Name -> Name -> TTerm a
unitVariant name fname = TTerm $ Terms.inject name $ Field fname Terms.unit

-- | Create an unwrap function for a wrapped type
-- Example: unwrap (Name "Email")
unwrap :: Name -> TTerm (a -> b)
unwrap = TTerm . Terms.unwrap

-- | Create a union variant
-- Example: variant (Name "Result") (Name "success") (string "ok")
variant :: Name -> Name -> TTerm a -> TTerm b
variant name fname (TTerm term) = TTerm $ Terms.inject name $ Field fname term

-- | Create a wrapped term (instance of a newtype)
-- Example: wrap (Name "Email") (string "user@example.com")
-- Note: the phantom types provide no guarantee of type safety in this case
wrap :: Name -> TTerm a -> TTerm b
wrap name (TTerm term) = TTerm $ Terms.wrap name term

-- * Pattern matching

-- | Apply a named case match to an argument
-- Example: cases resultTypeName myResult Nothing [onSuccess, onError]
-- See also: 'match'
cases :: Name -> TTerm a -> Maybe (TTerm b) -> [Field] -> TTerm b
cases name arg dflt fields = TTerm $ Terms.apply (Terms.match name (unTTerm <$> dflt) fields) (unTTerm arg)

-- | Create a pattern match on a union term
-- Example: match (Name "Result") (Just $ string "what?") ["success">: string "yay", "error">: string "boo"]
match :: Name -> Maybe (TTerm b) -> [Field] -> TTerm (a -> b)
match name dflt fields = TTerm $ Terms.match name (unTTerm <$> dflt) fields

optCases :: TTerm (Maybe a) -> TTerm b -> TTerm (a -> b) -> TTerm b
optCases arg ifNothing ifJust = primitive3 (Name "hydra.lib.optionals.maybe") ifNothing ifJust arg

-- * Definitions and modules

-- | Create a definition in a module
-- Example: definitionInModule myModule "addInts" (lambda "x" (lambda "y" (add @@ var "x" @@ var "y")))
definitionInModule :: Module -> String -> TTerm a -> TBinding a
definitionInModule mod = definitionInNamespace $ moduleNamespace mod

-- | Create a definition in a namespace
-- Example: definitionInNamespace (Namespace "com.example") "addInts" myFunction
definitionInNamespace :: Namespace -> String -> TTerm a -> TBinding a
definitionInNamespace ns lname = TBinding $ unqualifyName $ QualifiedName (Just ns) lname

-- | Convert a typed element to an untyped element
-- Example: el (definitionInModule myModule "addInts" myFunction)
el :: TBinding a -> Binding
el (TBinding name (TTerm term)) = Binding name term Nothing

-- | Reference a defined element
-- Example: ref (definitionInModule myModule "addInts")
ref :: TBinding a -> TTerm a
ref (TBinding name _) = TTerm (TermVariable name)

-- * Metadata and annotations

-- | Add an annotation to a term
-- Example: annot (Name "deprecated") (Just (boolean True)) myFunction
annot :: Name -> Maybe Term -> TTerm a -> TTerm a
annot key mvalue (TTerm term) = TTerm $ Ann.annotateTerm key mvalue term

-- | Add documentation to a term
-- Example: doc "Adds two integers" addFunction
doc :: String -> TTerm a -> TTerm a
doc s (TTerm term) = TTerm $ setTermDescription (Just s) term

-- | Add documentation with line wrapping at the specified width
-- Example: docWrapped 80 "This is a long documentation string that will be wrapped..." myFunction
docWrapped :: Int -> String -> TTerm a -> TTerm a
docWrapped len = doc . wrapLine len

-- | Mark a type as first-class
-- Example: firstClassType (record ...)
firstClassType :: TTerm Type -> TTerm Type
firstClassType typ = annot key_firstClassType (Just $ Terms.boolean True) typ

-- | Associate the Ord type class with the inferred type of a term
-- Example: withOrd "t0" myTerm
withOrd :: String -> TTerm a -> TTerm a
withOrd v = withTypeClasses $ M.fromList [(Name v, S.singleton TypeClassOrdering)]

-- | Associate type classes with the inferred type of a term
-- Example: withTypeClasses (M.fromList [(Name "t0", S.singleton TypeClassOrdering)]) myTerm
withTypeClasses :: M.Map Name (S.Set TypeClass) -> TTerm a -> TTerm a
withTypeClasses classes (TTerm term) = TTerm $ setTypeClasses classes term