module Hydra.Lexical (
  module Hydra.Lexical,
  module Hydra.Common,
  ) where

import Hydra.Common
import Hydra.Core
import Hydra.Module
import Hydra.Compute
import Hydra.Mantle
import Hydra.Monads

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Maybe as Y
import Control.Monad


deref :: Term m -> GraphFlow m (Term m)
deref :: forall m. Term m -> GraphFlow m (Term m)
deref Term m
term = case forall m. Term m -> Term m
stripTerm Term m
term of
  TermElement Name
name -> forall m. Name -> GraphFlow m (Term m)
dereferenceElement Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall m. Term m -> GraphFlow m (Term m)
deref
  TermNominal (Named Name
_ Term m
term') -> forall m. Term m -> GraphFlow m (Term m)
deref Term m
term'
  Term m
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term m
term

dereferenceElement :: Name -> GraphFlow m (Term m)
dereferenceElement :: forall m. Name -> GraphFlow m (Term m)
dereferenceElement Name
en = do
    Context m
cx <- forall s. Flow s s
getState
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
en (forall m. Graph m -> Map Name (Element m)
graphElements forall a b. (a -> b) -> a -> b
$ forall m. Context m -> Graph m
contextGraph Context m
cx) of
      Maybe (Element m)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"element " forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
en forall a. [a] -> [a] -> [a]
++ String
" does not exist"
      Just Element m
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Term m
elementData Element m
e

lookupPrimitiveFunction :: Context m -> Name -> Maybe (PrimitiveFunction m)
lookupPrimitiveFunction :: forall m. Context m -> Name -> Maybe (PrimitiveFunction m)
lookupPrimitiveFunction Context m
cx Name
fn = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fn forall a b. (a -> b) -> a -> b
$ forall m. Context m -> Map Name (PrimitiveFunction m)
contextFunctions Context m
cx

primitiveFunctionArity :: PrimitiveFunction m -> Int
primitiveFunctionArity :: forall m. PrimitiveFunction m -> Int
primitiveFunctionArity = forall {a} {m}. Num a => FunctionType m -> a
arity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. PrimitiveFunction m -> FunctionType m
primitiveFunctionType
  where
    arity :: FunctionType m -> a
arity (FunctionType Type m
_ Type m
cod) = a
1 forall a. Num a => a -> a -> a
+ case forall m. Type m -> Type m
stripType Type m
cod of
      TypeFunction FunctionType m
ft -> FunctionType m -> a
arity FunctionType m
ft
      Type m
_ -> a
0

requireElement :: Name -> GraphFlow m (Element m)
requireElement :: forall m. Name -> GraphFlow m (Element m)
requireElement Name
name = do
    Context m
cx <- forall s. Flow s s
getState
    forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (forall {m :: * -> *} {m} {a}. MonadFail m => Context m -> m a
err Context m
cx) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name forall a b. (a -> b) -> a -> b
$ forall m. Graph m -> Map Name (Element m)
graphElements forall a b. (a -> b) -> a -> b
$ forall m. Context m -> Graph m
contextGraph Context m
cx
  where
    err :: Context m -> m a
err Context m
cx = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"no such element: " forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name
        forall a. [a] -> [a] -> [a]
++ String
". Available elements: {" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ([String] -> [String]
ellipsis (Name -> String
unName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Element m -> Name
elementName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
M.elems (forall m. Graph m -> Map Name (Element m)
graphElements forall a b. (a -> b) -> a -> b
$ forall m. Context m -> Graph m
contextGraph Context m
cx))) forall a. [a] -> [a] -> [a]
++ String
"}"
      where
        ellipsis :: [String] -> [String]
ellipsis [String]
strings = if forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [String]
strings forall a. Ord a => a -> a -> Bool
> Int
3
--        ellipsis strings = if L.length strings < 0
          then forall a. Int -> [a] -> [a]
L.take Int
3 [String]
strings forall a. [a] -> [a] -> [a]
++ [String
"..."]
          else [String]
strings

requirePrimitiveFunction :: Name -> GraphFlow m (PrimitiveFunction m)
requirePrimitiveFunction :: forall m. Name -> GraphFlow m (PrimitiveFunction m)
requirePrimitiveFunction Name
fn = do
    Context m
cx <- forall s. Flow s s
getState
    forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe forall {a}. Flow (Context m) a
err forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Context m -> Name -> Maybe (PrimitiveFunction m)
lookupPrimitiveFunction Context m
cx Name
fn
  where
    err :: Flow (Context m) a
err = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"no such primitive function: " forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
fn

-- Note: assuming for now that primitive functions and evaluation strategy are the same in the schema graph
schemaContext :: Context m -> Context m
schemaContext :: forall m. Context m -> Context m
schemaContext Context m
cx = case forall m. Graph m -> Maybe (Graph m)
graphSchema (forall m. Context m -> Graph m
contextGraph Context m
cx) of
  Maybe (Graph m)
Nothing -> Context m
cx
  Just Graph m
g -> Context m
cx {contextGraph :: Graph m
contextGraph = Graph m
g}

withSchemaContext :: GraphFlow m a -> GraphFlow m a
withSchemaContext :: forall m a. GraphFlow m a -> GraphFlow m a
withSchemaContext GraphFlow m a
f = do
  Context m
cx <- forall s. Flow s s
getState
  forall s1 a s2. s1 -> Flow s1 a -> Flow s2 a
withState (forall m. Context m -> Context m
schemaContext Context m
cx) GraphFlow m a
f