{-# LANGUAGE TupleSections #-}

{- |
Module      : Language.Egison.Desugar
Licence     : MIT

This module implements Phase 3-4: Syntactic Desugaring (for untyped path).
For the typed path, desugaring is done inside type inference.

Syntactic Desugaring (Phase 3-4):
  - Operator desugaring (infix to function application)
  - Anonymous function expansion (cambda: 1#($1 + $2) etc.)
  - Match-lambda expansion (convert to match expressions)
  - Other syntactic sugar expansions
  
Design Note (design/implementation.md):
Pattern matching itself is NOT desugared here. Match expressions (IMatchExpr, 
IMatchAllExpr) are kept as-is and processed during evaluation (Phase 10).
This allows Egison's sophisticated pattern matching to be implemented in the evaluator.
-}

module Language.Egison.Desugar
    ( desugarTopExpr
    , desugarTopExprs
    , desugarExpr
    , transVarIndex
    ) where

import           Control.Monad.Except   (throwError)
import           Data.Char              (toUpper)
import           Data.Foldable          (foldrM)
import           Data.List              (union)
import           Data.Text              (pack)

import           Language.Egison.AST
import           Language.Egison.Data
import           Language.Egison.IExpr
import           Language.Egison.RState
import           Language.Egison.Type.Types (sanitizeMethodName, typeToName, typeConstructorName, 
                                             typeExprToType, capitalizeFirst, lowerFirst, TyVar(..))


desugarTopExpr :: TopExpr -> EvalM (Maybe ITopExpr)
desugarTopExpr :: TopExpr -> EvalM (Maybe ITopExpr)
desugarTopExpr (Define VarWithIndices
vwi Expr
expr) = do
  (Var
var, IExpr
iexpr) <- VarWithIndices -> Expr -> EvalM (Var, IExpr)
desugarDefineWithIndices VarWithIndices
vwi Expr
expr
  Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> (ITopExpr -> Maybe ITopExpr)
-> ITopExpr
-> EvalM (Maybe ITopExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> EvalM (Maybe ITopExpr))
-> ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ Var -> IExpr -> ITopExpr
IDefine Var
var IExpr
iexpr
desugarTopExpr (DefineWithType TypedVarWithIndices
typedVwi Expr
expr) = do
  -- Convert typed definition to regular definition
  -- Type information is used for type checking, but the runtime representation is the same
  -- Note: Constraints are preserved in the type scheme (by EnvBuilder),
  -- and dictionary passing is handled in TypeClassExpand phase
  let name :: String
name = TypedVarWithIndices -> String
typedVarName TypedVarWithIndices
typedVwi
      indices :: [VarIndex]
indices = TypedVarWithIndices -> [VarIndex]
typedVarIndices TypedVarWithIndices
typedVwi
      params :: [TypedParam]
params = TypedVarWithIndices -> [TypedParam]
typedVarParams TypedVarWithIndices
typedVwi
      vwi :: VarWithIndices
vwi = String -> [VarIndex] -> VarWithIndices
VarWithIndices String
name [VarIndex]
indices
  -- If there are typed parameters, wrap the body in a lambda
  case [TypedParam]
params of
    [] -> do
      (Var
var, IExpr
iexpr) <- VarWithIndices -> Expr -> EvalM (Var, IExpr)
desugarDefineWithIndices VarWithIndices
vwi Expr
expr
      Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> (ITopExpr -> Maybe ITopExpr)
-> ITopExpr
-> EvalM (Maybe ITopExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> EvalM (Maybe ITopExpr))
-> ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ Var -> IExpr -> ITopExpr
IDefine Var
var IExpr
iexpr
    [TypedParam]
_  -> do
      -- Create lambda arguments from typed parameters
      let argPatterns :: [Arg ArgPattern]
argPatterns = (TypedParam -> Arg ArgPattern) -> [TypedParam] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map TypedParam -> Arg ArgPattern
typedParamToArgPattern [TypedParam]
params
          lambdaExpr :: Expr
lambdaExpr = [Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern]
argPatterns Expr
expr
      (Var
var, IExpr
iexpr) <- VarWithIndices -> Expr -> EvalM (Var, IExpr)
desugarDefineWithIndices VarWithIndices
vwi Expr
lambdaExpr
      Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> (ITopExpr -> Maybe ITopExpr)
-> ITopExpr
-> EvalM (Maybe ITopExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> EvalM (Maybe ITopExpr))
-> ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ Var -> IExpr -> ITopExpr
IDefine Var
var IExpr
iexpr
desugarTopExpr (Test Expr
expr)     = ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> Maybe ITopExpr)
-> (IExpr -> ITopExpr) -> IExpr -> Maybe ITopExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IExpr -> ITopExpr
ITest (IExpr -> Maybe ITopExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> EvalM (Maybe ITopExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
desugarTopExpr (Execute Expr
expr)  = ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> Maybe ITopExpr)
-> (IExpr -> ITopExpr) -> IExpr -> Maybe ITopExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IExpr -> ITopExpr
IExecute (IExpr -> Maybe ITopExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> EvalM (Maybe ITopExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
desugarTopExpr (Load String
file)     = Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> (ITopExpr -> Maybe ITopExpr)
-> ITopExpr
-> EvalM (Maybe ITopExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> EvalM (Maybe ITopExpr))
-> ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ String -> ITopExpr
ILoad String
file
desugarTopExpr (LoadFile String
file) = Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> (ITopExpr -> Maybe ITopExpr)
-> ITopExpr
-> EvalM (Maybe ITopExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> EvalM (Maybe ITopExpr))
-> ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ String -> ITopExpr
ILoadFile String
file

-- Type class declarations: generate dictionary-passing wrapper functions
-- and register the class methods for dispatch
-- For a class like:
--   class Eq a where
--     (==) (x: a) (y: a) : Bool
-- We generate:
--   1. Dictionary wrapper: def classEqEq dict x y := (dict_"eq") x y
--   2. Instance registry variable: def registryEq := {| |}
--   3. Auto-dispatch function: def autoEqEq x y := (resolveEq x)_"eq" x y
desugarTopExpr (ClassDeclExpr (ClassDecl String
classNm [String]
_typeParams [ConstraintExpr]
_supers [ClassMethod]
methods)) = do
  -- Generate dictionary-passing wrapper functions for each method
  [(Var, IExpr)]
methodWrappers <- (ClassMethod -> EvalM (Var, IExpr))
-> [ClassMethod]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [(Var, IExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> ClassMethod -> EvalM (Var, IExpr)
desugarClassMethod String
classNm) [ClassMethod]
methods
  -- Generate empty instance registry
  let registryDef :: (Var, IExpr)
registryDef = String -> (Var, IExpr)
makeRegistryDef String
classNm
  case [(Var, IExpr)]
methodWrappers of
    [] -> Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ITopExpr
forall a. Maybe a
Nothing
    [(Var, IExpr)]
_  -> Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> Maybe ITopExpr) -> ITopExpr -> Maybe ITopExpr
forall a b. (a -> b) -> a -> b
$ [(Var, IExpr)] -> ITopExpr
IDefineMany ((Var, IExpr)
registryDef (Var, IExpr) -> [(Var, IExpr)] -> [(Var, IExpr)]
forall a. a -> [a] -> [a]
: [(Var, IExpr)]
methodWrappers)
  where
    desugarClassMethod :: String -> ClassMethod -> EvalM (Var, IExpr)
    desugarClassMethod :: String -> ClassMethod -> EvalM (Var, IExpr)
desugarClassMethod String
clsNm (ClassMethod String
methName [TypedParam]
methParams TypeExpr
_retType Maybe Expr
_defaultImpl) = do
      -- Generate function name: e.g., "classEqEq" for (==) in Eq
      let wrapperName :: String
wrapperName = String
"class" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalizeFirst (String -> String
sanitizeMethodName String
methName)
          var :: Var
var = String -> Var
stringToVar String
wrapperName
          dictVar :: String
dictVar = String
"dict"
          -- Parameter names: dict, x, y, ...
          paramNames :: [String]
paramNames = (TypedParam -> String) -> [TypedParam] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TypedParam -> String
extractParamName [TypedParam]
methParams
          allParams :: [String]
allParams = String
dictVar String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
paramNames
      -- Build the body: (dict_"methodName") x y ...
      -- dict_"eq" is hash access, then apply to remaining params
      let dictAccessExpr :: IExpr
dictAccessExpr = Bool -> IExpr -> [Index IExpr] -> IExpr
IIndexedExpr Bool
False (String -> IExpr
IVarExpr String
dictVar) 
                             [IExpr -> Index IExpr
forall a. a -> Index a
Sub (ConstantExpr -> IExpr
IConstantExpr (Text -> ConstantExpr
StringExpr (String -> Text
pack (String -> String
sanitizeMethodName String
methName))))]
          bodyExpr :: IExpr
bodyExpr = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
paramNames
                     then IExpr
dictAccessExpr
                     else IExpr -> [IExpr] -> IExpr
IApplyExpr IExpr
dictAccessExpr ((String -> IExpr) -> [String] -> [IExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> IExpr
IVarExpr [String]
paramNames)
          lambdaExpr :: IExpr
lambdaExpr = Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing ((String -> Var) -> [String] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map String -> Var
stringToVar [String]
allParams) IExpr
bodyExpr
      (Var, IExpr) -> EvalM (Var, IExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
var, IExpr
lambdaExpr)
    
    -- Create empty instance registry: registryEq := {| |}
    makeRegistryDef :: String -> (Var, IExpr)
    makeRegistryDef :: String -> (Var, IExpr)
makeRegistryDef String
clsNm = 
      let registryName :: String
registryName = String
"registry" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
clsNm
          var :: Var
var = String -> Var
stringToVar String
registryName
      in (Var
var, [(IExpr, IExpr)] -> IExpr
IHashExpr [])
    
    extractParamName :: TypedParam -> String
    extractParamName :: TypedParam -> String
extractParamName (TPVar String
name TypeExpr
_) = String
name
    extractParamName (TPInvertedVar String
name TypeExpr
_) = String
name
    extractParamName (TPUntypedVar String
name) = String
name
    extractParamName TypedParam
_ = String
"x"  -- fallback

-- Instance declarations: generate a dictionary and individual method definitions
-- For an instance like:
--   instance Eq Integer where
--     (==) x y := x = y
--     (/=) x y := not (x = y)
-- We generate:
--   1. Individual method functions:
--      def eqIntegerEq x y := x = y
--      def eqIntegerNeq x y := not (x = y)
--   2. A dictionary for the instance:
--      def eqInteger := {| ("eq", eqIntegerEq), ("neq", eqIntegerNeq) |}
desugarTopExpr (InstanceDeclExpr (InstanceDecl [ConstraintExpr]
constraints String
classNm [TypeExpr]
instTypes [InstanceMethod]
methods)) = do
  -- Check if instTypes is not empty
  if [TypeExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeExpr]
instTypes
    then Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ITopExpr
forall a. Maybe a
Nothing
    else do
      -- Use type constructor name only (without type parameters)
      -- e.g., "Collection" not "Collectiona" for [a]
      let instTypeName :: String
instTypeName = Type -> String
typeConstructorName (TypeExpr -> Type
typeExprToType ([TypeExpr] -> TypeExpr
forall a. HasCallStack => [a] -> a
head [TypeExpr]
instTypes))
      -- Generate individual method definitions with constraint parameters
      [(Var, IExpr)]
methodDefs <- (InstanceMethod -> EvalM (Var, IExpr))
-> [InstanceMethod]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [(Var, IExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([ConstraintExpr]
-> String -> String -> InstanceMethod -> EvalM (Var, IExpr)
desugarInstanceMethod [ConstraintExpr]
constraints String
classNm String
instTypeName) [InstanceMethod]
methods
      -- Generate dictionary definition (with constraints if any)
      let dictDef :: (Var, IExpr)
dictDef = [ConstraintExpr]
-> String -> String -> [InstanceMethod] -> (Var, IExpr)
makeDictDef [ConstraintExpr]
constraints String
classNm String
instTypeName [InstanceMethod]
methods
      -- Return all definitions
      case [(Var, IExpr)]
methodDefs of
        []  -> Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ITopExpr
forall a. Maybe a
Nothing
        [(Var, IExpr)]
_   -> Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> Maybe ITopExpr) -> ITopExpr -> Maybe ITopExpr
forall a b. (a -> b) -> a -> b
$ [(Var, IExpr)] -> ITopExpr
IDefineMany ((Var, IExpr)
dictDef (Var, IExpr) -> [(Var, IExpr)] -> [(Var, IExpr)]
forall a. a -> [a] -> [a]
: [(Var, IExpr)]
methodDefs)
  where
    desugarInstanceMethod :: [ConstraintExpr] -> String -> String -> InstanceMethod -> EvalM (Var, IExpr)
    desugarInstanceMethod :: [ConstraintExpr]
-> String -> String -> InstanceMethod -> EvalM (Var, IExpr)
desugarInstanceMethod [ConstraintExpr]
_constrs String
clsNm String
typNm (InstanceMethod String
methName [String]
params Expr
body) = do
      -- Generate function name using type constructor name only
      -- e.g., "eqCollectionEq" not "eqCollectionaEq" for instance {Eq a} Eq [a]
      let funcName :: String
funcName = String -> String
lowerFirst String
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalizeFirst (String -> String
sanitizeMethodName String
methName)
          var :: Var
var = String -> Var
stringToVar String
funcName
      
      -- Do NOT add dictionary parameters here!
      -- Dictionary parameters will be added automatically by addDictionaryParametersT
      -- after type inference, based on the inferred constraints.
      -- This allows the method body to be properly type-checked with constraints.
      
      -- Create lambda expression with only the method parameters
      let lambdaArgs :: [Arg ArgPattern]
lambdaArgs = (String -> Arg ArgPattern) -> [String] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map (\String
p -> ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (VarWithIndices -> ArgPattern
APPatVar (String -> [VarIndex] -> VarWithIndices
VarWithIndices String
p []))) [String]
params
          lambdaExpr :: Expr
lambdaExpr = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
params then Expr
body else [Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern]
lambdaArgs Expr
body
      IExpr
iexpr <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
lambdaExpr
      (Var, IExpr) -> EvalM (Var, IExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
var, IExpr
iexpr)
    
    makeDictDef :: [ConstraintExpr] -> String -> String -> [InstanceMethod] -> (Var, IExpr)
    makeDictDef :: [ConstraintExpr]
-> String -> String -> [InstanceMethod] -> (Var, IExpr)
makeDictDef [ConstraintExpr]
_constrs String
clsNm String
typNm [InstanceMethod]
meths =
      let dictName :: String
dictName = String -> String
lowerFirst String
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typNm  -- e.g., "eqCollection"
          dictVar :: Var
dictVar = String -> Var
stringToVar String
dictName
          
          -- For nested instances (with constraints), the dictionary becomes a function
          -- that takes dictionary parameters and returns a hash.
          -- e.g., for instance {Eq a} Eq [a]:
          --   eqCollection = \dict_Eq -> {| ("eq", eqCollectionEq dict_Eq), ... |}
          --
          -- Dictionary parameters will be automatically added by addDictionaryParametersT
          -- after type inference, so we don't add them here manually.
          -- We just create the hash with references to the methods.
          
          hashEntries :: [(IExpr, IExpr)]
hashEntries = (InstanceMethod -> (IExpr, IExpr))
-> [InstanceMethod] -> [(IExpr, IExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> InstanceMethod -> (IExpr, IExpr)
makeHashEntry String
clsNm String
typNm) [InstanceMethod]
meths
          hashExpr :: IExpr
hashExpr = [(IExpr, IExpr)] -> IExpr
IHashExpr [(IExpr, IExpr)]
hashEntries
      in (Var
dictVar, IExpr
hashExpr)
    
    makeHashEntry :: String -> String -> InstanceMethod -> (IExpr, IExpr)
    makeHashEntry :: String -> String -> InstanceMethod -> (IExpr, IExpr)
makeHashEntry String
clsNm String
typNm (InstanceMethod String
methName [String]
_ Expr
_) =
      let keyExpr :: IExpr
keyExpr = ConstantExpr -> IExpr
IConstantExpr (Text -> ConstantExpr
StringExpr (String -> Text
pack (String -> String
sanitizeMethodName String
methName)))
          -- Reference to the method function
          funcName :: String
funcName = String -> String
lowerFirst String
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalizeFirst (String -> String
sanitizeMethodName String
methName)
          valueExpr :: IExpr
valueExpr = String -> IExpr
IVarExpr String
funcName
      in (IExpr
keyExpr, IExpr
valueExpr)
    

-- Inductive declarations don't produce runtime code
-- Constructor registration is handled by the type system
desugarTopExpr (InductiveDecl String
_ [String]
_ [InductiveConstructor]
_) = Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ITopExpr
forall a. Maybe a
Nothing

-- Infix declarations don't produce runtime code
desugarTopExpr (InfixDecl Bool
_ Op
_) = Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ITopExpr
forall a. Maybe a
Nothing
desugarTopExpr (PatternInductiveDecl String
_ [String]
_ [PatternConstructor]
_) = Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ITopExpr
forall a. Maybe a
Nothing  -- Handled in environment building phase

-- Pattern function declarations need type checking, so convert to IPatternFunctionDecl
desugarTopExpr (PatternFunctionDecl String
name [String]
typeParams [(String, TypeExpr)]
params TypeExpr
retType Pattern
body) = do
  let paramTypes :: [(String, Type)]
paramTypes = ((String, TypeExpr) -> (String, Type))
-> [(String, TypeExpr)] -> [(String, Type)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
pname, TypeExpr
pty) -> (String
pname, TypeExpr -> Type
typeExprToType TypeExpr
pty)) [(String, TypeExpr)]
params
      retType' :: Type
retType' = TypeExpr -> Type
typeExprToType TypeExpr
retType
      tyVars :: [TyVar]
tyVars = (String -> TyVar) -> [String] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map String -> TyVar
TyVar [String]
typeParams
  IPattern
body' <- Pattern -> EvalM IPattern
desugarPattern Pattern
body
  Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> (ITopExpr -> Maybe ITopExpr)
-> ITopExpr
-> EvalM (Maybe ITopExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> EvalM (Maybe ITopExpr))
-> ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ String
-> [TyVar] -> [(String, Type)] -> Type -> IPattern -> ITopExpr
IPatternFunctionDecl String
name [TyVar]
tyVars [(String, Type)]
paramTypes Type
retType' IPattern
body'

-- Symbol declarations
desugarTopExpr (DeclareSymbol [String]
names Maybe TypeExpr
mTypeExpr) = do
  -- Convert type expression to type (defaults to Integer if not specified)
  let ty :: Type
ty = case Maybe TypeExpr
mTypeExpr of
             Just TypeExpr
texpr -> TypeExpr -> Type
typeExprToType TypeExpr
texpr
             Maybe TypeExpr
Nothing    -> TypeExpr -> Type
typeExprToType TypeExpr
TEInt
  Maybe ITopExpr -> EvalM (Maybe ITopExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ITopExpr -> EvalM (Maybe ITopExpr))
-> (ITopExpr -> Maybe ITopExpr)
-> ITopExpr
-> EvalM (Maybe ITopExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ITopExpr -> Maybe ITopExpr
forall a. a -> Maybe a
Just (ITopExpr -> EvalM (Maybe ITopExpr))
-> ITopExpr -> EvalM (Maybe ITopExpr)
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe Type -> ITopExpr
IDeclareSymbol [String]
names (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty)

-- | Convert TypedParam to Arg ArgPattern for lambda expressions
typedParamToArgPattern :: TypedParam -> Arg ArgPattern
typedParamToArgPattern :: TypedParam -> Arg ArgPattern
typedParamToArgPattern (TPVar String
pname TypeExpr
_) =
  ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (VarWithIndices -> ArgPattern
APPatVar (String -> [VarIndex] -> VarWithIndices
VarWithIndices String
pname []))
typedParamToArgPattern (TPInvertedVar String
pname TypeExpr
_) =
  ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
InvertedArg (VarWithIndices -> ArgPattern
APPatVar (String -> [VarIndex] -> VarWithIndices
VarWithIndices String
pname []))
typedParamToArgPattern (TPTuple [TypedParam]
elems) =
  ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg ([Arg ArgPattern] -> ArgPattern
APTuplePat ((TypedParam -> Arg ArgPattern) -> [TypedParam] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map TypedParam -> Arg ArgPattern
typedParamToArgPattern [TypedParam]
elems))
typedParamToArgPattern (TPWildcard TypeExpr
_) =
  ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg ArgPattern
APWildCard
typedParamToArgPattern (TPUntypedVar String
pname) =
  ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (VarWithIndices -> ArgPattern
APPatVar (String -> [VarIndex] -> VarWithIndices
VarWithIndices String
pname []))
typedParamToArgPattern TypedParam
TPUntypedWildcard =
  ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg ArgPattern
APWildCard

desugarTopExprs :: [TopExpr] -> EvalM [ITopExpr]
desugarTopExprs :: [TopExpr] -> EvalM [ITopExpr]
desugarTopExprs [] = [ITopExpr] -> EvalM [ITopExpr]
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
desugarTopExprs (TopExpr
expr : [TopExpr]
exprs) = do
  Maybe ITopExpr
expr' <- TopExpr -> EvalM (Maybe ITopExpr)
desugarTopExpr TopExpr
expr
  case Maybe ITopExpr
expr' of
    Maybe ITopExpr
Nothing    -> [TopExpr] -> EvalM [ITopExpr]
desugarTopExprs [TopExpr]
exprs
    Just ITopExpr
expr' -> (ITopExpr
expr' :) ([ITopExpr] -> [ITopExpr]) -> EvalM [ITopExpr] -> EvalM [ITopExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TopExpr] -> EvalM [ITopExpr]
desugarTopExprs [TopExpr]
exprs

desugarExpr :: Expr -> EvalM IExpr
desugarExpr :: Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugarExpr = Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar

desugar :: Expr -> EvalM IExpr
desugar :: Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (ConstantExpr ConstantExpr
c) = IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ ConstantExpr -> IExpr
IConstantExpr ConstantExpr
c
desugar (VarExpr String
var)    = IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> IExpr
IVarExpr String
var

desugar (AlgebraicDataMatcherExpr [(String, [Expr])]
patterns) = do
  String
matcherName <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  let matcherRef :: IExpr
matcherRef = String -> IExpr
IVarExpr String
matcherName
  IExpr
matcher <- [(String, [Expr])]
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
genMatcherClauses [(String, [Expr])]
patterns IExpr
matcherRef
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [IBindingExpr] -> IExpr -> IExpr
ILetRecExpr [(Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
matcherName), IExpr
matcher)] IExpr
matcherRef
    where
      genMatcherClauses :: [(String, [Expr])] ->  IExpr -> EvalM IExpr
      genMatcherClauses :: [(String, [Expr])]
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
genMatcherClauses [(String, [Expr])]
patterns IExpr
matcher = do
        (PrimitivePatPattern, IExpr, [IBindingExpr])
main <- [(String, [Expr])]
-> IExpr -> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
genMainClause [(String, [Expr])]
patterns IExpr
matcher
        [(PrimitivePatPattern, IExpr, [IBindingExpr])]
body <- ((String, [Expr])
 -> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr]))
-> [(String, [Expr])]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(PrimitivePatPattern, IExpr, [IBindingExpr])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String, [Expr])
-> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
genMatcherClause [(String, [Expr])]
patterns
        (PrimitivePatPattern, IExpr, [IBindingExpr])
footer <- EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
genSomethingClause
        let clauses :: [(PrimitivePatPattern, IExpr, [IBindingExpr])]
clauses = [(PrimitivePatPattern, IExpr, [IBindingExpr])
main] [(PrimitivePatPattern, IExpr, [IBindingExpr])]
-> [(PrimitivePatPattern, IExpr, [IBindingExpr])]
-> [(PrimitivePatPattern, IExpr, [IBindingExpr])]
forall a. [a] -> [a] -> [a]
++ [(PrimitivePatPattern, IExpr, [IBindingExpr])]
body [(PrimitivePatPattern, IExpr, [IBindingExpr])]
-> [(PrimitivePatPattern, IExpr, [IBindingExpr])]
-> [(PrimitivePatPattern, IExpr, [IBindingExpr])]
forall a. [a] -> [a] -> [a]
++ [(PrimitivePatPattern, IExpr, [IBindingExpr])
footer]
        IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [(PrimitivePatPattern, IExpr, [IBindingExpr])] -> IExpr
IMatcherExpr [(PrimitivePatPattern, IExpr, [IBindingExpr])]
clauses

      genMainClause :: [(String, [Expr])] -> IExpr -> EvalM (PrimitivePatPattern, IExpr, [(IPrimitiveDataPattern, IExpr)])
      genMainClause :: [(String, [Expr])]
-> IExpr -> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
genMainClause [(String, [Expr])]
patterns IExpr
matcher = do
        [IMatchClause]
clauses <- [(String, [Expr])] -> EvalM [IMatchClause]
genClauses [(String, [Expr])]
patterns
        (PrimitivePatPattern, IExpr, [IBindingExpr])
-> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> PrimitivePatPattern
PPValuePat String
"val", [IExpr] -> IExpr
ITupleExpr [],
                [(Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
"tgt"),
                    PMMode -> IExpr -> IExpr -> [IMatchClause] -> IExpr
IMatchExpr PMMode
BFSMode
                               ([IExpr] -> IExpr
ITupleExpr [String -> IExpr
IVarExpr String
"val", String -> IExpr
IVarExpr String
"tgt"])
                               ([IExpr] -> IExpr
ITupleExpr [IExpr
matcher, IExpr
matcher])
                               [IMatchClause]
clauses)])
        where
          genClauses :: [(String, [Expr])] -> EvalM [IMatchClause]
          genClauses :: [(String, [Expr])] -> EvalM [IMatchClause]
genClauses [(String, [Expr])]
patterns = [IMatchClause] -> [IMatchClause] -> [IMatchClause]
forall a. [a] -> [a] -> [a]
(++) ([IMatchClause] -> [IMatchClause] -> [IMatchClause])
-> EvalM [IMatchClause]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([IMatchClause] -> [IMatchClause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, [Expr])
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IMatchClause)
-> [(String, [Expr])] -> EvalM [IMatchClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String, [Expr])
-> StateT EvalState (ExceptT EgisonError RuntimeM) IMatchClause
genClause [(String, [Expr])]
patterns
                                     StateT
  EvalState
  (ExceptT EgisonError RuntimeM)
  ([IMatchClause] -> [IMatchClause])
-> EvalM [IMatchClause] -> EvalM [IMatchClause]
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [IMatchClause] -> EvalM [IMatchClause]
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [([IPattern] -> IPattern
ITuplePat [IPattern
IWildCard, IPattern
IWildCard], IExpr
matchingFailure)]

          genClause :: (String, [Expr]) -> EvalM IMatchClause
          genClause :: (String, [Expr])
-> StateT EvalState (ExceptT EgisonError RuntimeM) IMatchClause
genClause (String, [Expr])
pattern = do
            (IPattern
pat0, IPattern
pat1) <- (String, [Expr]) -> EvalM (IPattern, IPattern)
genMatchingPattern (String, [Expr])
pattern
            IMatchClause
-> StateT EvalState (ExceptT EgisonError RuntimeM) IMatchClause
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([IPattern] -> IPattern
ITuplePat [IPattern
pat0, IPattern
pat1], IExpr
matchingSuccess)

          genMatchingPattern :: (String, [Expr]) -> EvalM (IPattern, IPattern)
          genMatchingPattern :: (String, [Expr]) -> EvalM (IPattern, IPattern)
genMatchingPattern (String
name, [Expr]
patterns) = do
            [String]
names <- (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) String)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT EvalState (ExceptT EgisonError RuntimeM) String
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) String
forall a b. a -> b -> a
const StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh) [Expr]
patterns
            (IPattern, IPattern) -> EvalM (IPattern, IPattern)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [IPattern] -> IPattern
IInductivePat String
name ((String -> IPattern) -> [String] -> [IPattern]
forall a b. (a -> b) -> [a] -> [b]
map String -> IPattern
IPatVar [String]
names),
                    String -> [IPattern] -> IPattern
IInductivePat String
name ((String -> IPattern) -> [String] -> [IPattern]
forall a b. (a -> b) -> [a] -> [b]
map (IExpr -> IPattern
IValuePat (IExpr -> IPattern) -> (String -> IExpr) -> String -> IPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IExpr
IVarExpr) [String]
names))

      genMatcherClause :: (String, [Expr]) -> EvalM (PrimitivePatPattern, IExpr, [(IPrimitiveDataPattern, IExpr)])
      genMatcherClause :: (String, [Expr])
-> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
genMatcherClause (String, [Expr])
pattern = do
        (PrimitivePatPattern
ppat, [IExpr]
matchers) <- (String, [Expr]) -> EvalM (PrimitivePatPattern, [IExpr])
genPrimitivePatPat (String, [Expr])
pattern
        (PDPatternBase Var
dpat, [IExpr]
body)     <- (String, [Expr]) -> EvalM (PDPatternBase Var, [IExpr])
genPrimitiveDataPat (String, [Expr])
pattern
        (PrimitivePatPattern, IExpr, [IBindingExpr])
-> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitivePatPattern
ppat, [IExpr] -> IExpr
ITupleExpr [IExpr]
matchers, [(PDPatternBase Var
dpat, [IExpr] -> IExpr
ICollectionExpr [[IExpr] -> IExpr
ITupleExpr [IExpr]
body]), (PDPatternBase Var
forall var. PDPatternBase var
PDWildCard, IExpr
matchingFailure)])

        where
          genPrimitivePatPat :: (String, [Expr]) -> EvalM (PrimitivePatPattern, [IExpr])
          genPrimitivePatPat :: (String, [Expr]) -> EvalM (PrimitivePatPattern, [IExpr])
genPrimitivePatPat (String
name, [Expr]
matchers) = do
            [PrimitivePatPattern]
patterns' <- (Expr
 -> StateT
      EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern)
-> [Expr]
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) [PrimitivePatPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern
-> Expr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern
forall a b. a -> b -> a
const (StateT
   EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern
 -> Expr
 -> StateT
      EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern)
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern
-> Expr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern
forall a b. (a -> b) -> a -> b
$ PrimitivePatPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) PrimitivePatPattern
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return PrimitivePatPattern
PPPatVar) [Expr]
matchers
            [IExpr]
matchers' <- (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
matchers
            (PrimitivePatPattern, [IExpr])
-> EvalM (PrimitivePatPattern, [IExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [PrimitivePatPattern] -> PrimitivePatPattern
PPInductivePat String
name [PrimitivePatPattern]
patterns', [IExpr]
matchers')

          genPrimitiveDataPat :: (String, [Expr]) -> EvalM (IPrimitiveDataPattern, [IExpr])
          genPrimitiveDataPat :: (String, [Expr]) -> EvalM (PDPatternBase Var, [IExpr])
genPrimitiveDataPat (String
name, [Expr]
patterns) = do
            [String]
patterns' <- (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) String)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT EvalState (ExceptT EgisonError RuntimeM) String
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) String
forall a b. a -> b -> a
const StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh) [Expr]
patterns
            (PDPatternBase Var, [IExpr]) -> EvalM (PDPatternBase Var, [IExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [PDPatternBase Var] -> PDPatternBase Var
forall var. String -> [PDPatternBase var] -> PDPatternBase var
PDInductivePat (String -> String
capitalize String
name) ([PDPatternBase Var] -> PDPatternBase Var)
-> [PDPatternBase Var] -> PDPatternBase Var
forall a b. (a -> b) -> a -> b
$ (String -> PDPatternBase Var) -> [String] -> [PDPatternBase Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (Var -> PDPatternBase Var)
-> (String -> Var) -> String -> PDPatternBase Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Var
stringToVar) [String]
patterns', (String -> IExpr) -> [String] -> [IExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> IExpr
IVarExpr [String]
patterns')

          capitalize :: String -> String
          capitalize :: String -> String
capitalize (Char
x:String
xs) = Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs


      genSomethingClause :: EvalM (PrimitivePatPattern, IExpr, [(IPrimitiveDataPattern, IExpr)])
      genSomethingClause :: EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
genSomethingClause =
        (PrimitivePatPattern, IExpr, [IBindingExpr])
-> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitivePatPattern
PPPatVar, [IExpr] -> IExpr
ITupleExpr [ConstantExpr -> IExpr
IConstantExpr ConstantExpr
SomethingExpr], [(Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
"tgt"), [IExpr] -> IExpr
ICollectionExpr [String -> IExpr
IVarExpr String
"tgt"])])

      matchingSuccess :: IExpr
      matchingSuccess :: IExpr
matchingSuccess = [IExpr] -> IExpr
ICollectionExpr [[IExpr] -> IExpr
ITupleExpr []]

      matchingFailure :: IExpr
      matchingFailure :: IExpr
matchingFailure = [IExpr] -> IExpr
ICollectionExpr []

desugar (MatchAllLambdaExpr Expr
matcher [MatchClause]
clauses) = do
  String
name <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing [String -> Var
stringToVar String
name] (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (PMMode -> Expr -> Expr -> [MatchClause] -> Expr
MatchAllExpr PMMode
BFSMode (String -> Expr
VarExpr String
name) Expr
matcher [MatchClause]
clauses)

desugar (MatchLambdaExpr Expr
matcher [MatchClause]
clauses) = do
  String
name <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing [String -> Var
stringToVar String
name] (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (PMMode -> Expr -> Expr -> [MatchClause] -> Expr
MatchExpr PMMode
BFSMode (String -> Expr
VarExpr String
name) Expr
matcher [MatchClause]
clauses)

desugar (IndexedExpr Bool
override Expr
expr [IndexExpr Expr]
indices) = do
  IExpr
expr' <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
  Bool
-> IExpr
-> [IndexExpr Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugarIndexedExpr Bool
override IExpr
expr' [IndexExpr Expr]
indices
  where
    desugarIndexedExpr :: Bool -> IExpr -> [IndexExpr Expr] -> EvalM IExpr
    desugarIndexedExpr :: Bool
-> IExpr
-> [IndexExpr Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugarIndexedExpr Bool
override IExpr
expr' [IndexExpr Expr]
indices =
      case [IndexExpr Expr]
indices of
        [] -> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return IExpr
expr'
        (MultiSubscript Expr
x Expr
y:[IndexExpr Expr]
indices') ->
          case (Expr
x, Expr
y) of
            (IndexedExpr Bool
override1 Expr
e1 [IndexExpr Expr
n1], IndexedExpr Bool
_ Expr
_ [IndexExpr Expr
n2]) -> do
              IExpr
expr'' <- Bool
-> IExpr
-> (Bool -> IExpr -> IExpr -> IExpr)
-> Bool
-> Expr
-> IndexExpr Expr
-> IndexExpr Expr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall {t} {t} {b}.
t
-> t
-> (t -> t -> IExpr -> b)
-> Bool
-> Expr
-> IndexExpr Expr
-> IndexExpr Expr
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
desugarMultiScript Bool
override IExpr
expr' Bool -> IExpr -> IExpr -> IExpr
ISubrefsExpr Bool
override1 Expr
e1 IndexExpr Expr
n1 IndexExpr Expr
n2
              Bool
-> IExpr
-> [IndexExpr Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugarIndexedExpr Bool
False IExpr
expr'' [IndexExpr Expr]
indices'
            (Expr, Expr)
_ -> EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a.
EgisonError -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EgisonError
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> EgisonError
Default String
"Index should be IndexedExpr for multi subscript"
        (MultiSuperscript Expr
x Expr
y:[IndexExpr Expr]
indices') ->
          case (Expr
x, Expr
y) of
            (IndexedExpr Bool
override1 Expr
e1 [IndexExpr Expr
n1], IndexedExpr Bool
_ Expr
_ [IndexExpr Expr
n2]) -> do
              IExpr
expr'' <- Bool
-> IExpr
-> (Bool -> IExpr -> IExpr -> IExpr)
-> Bool
-> Expr
-> IndexExpr Expr
-> IndexExpr Expr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall {t} {t} {b}.
t
-> t
-> (t -> t -> IExpr -> b)
-> Bool
-> Expr
-> IndexExpr Expr
-> IndexExpr Expr
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
desugarMultiScript Bool
override IExpr
expr' Bool -> IExpr -> IExpr -> IExpr
ISuprefsExpr Bool
override1 Expr
e1 IndexExpr Expr
n1 IndexExpr Expr
n2
              Bool
-> IExpr
-> [IndexExpr Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugarIndexedExpr Bool
False IExpr
expr'' [IndexExpr Expr]
indices'
            (Expr, Expr)
_ -> EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a.
EgisonError -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EgisonError
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> EgisonError
Default String
"Index should be IndexedExpr for multi superscript"
        [IndexExpr Expr]
_ -> do
          let ([IndexExpr Expr]
is, [IndexExpr Expr]
indices') = (IndexExpr Expr -> Bool)
-> [IndexExpr Expr] -> ([IndexExpr Expr], [IndexExpr Expr])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break IndexExpr Expr -> Bool
forall {a}. IndexExpr a -> Bool
isMulti [IndexExpr Expr]
indices
          IExpr
expr'' <- Bool -> IExpr -> [Index IExpr] -> IExpr
IIndexedExpr Bool
override IExpr
expr' ([Index IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [Index IExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IndexExpr Expr
 -> StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr))
-> [IndexExpr Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [Index IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IndexExpr Expr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr)
desugarIndex [IndexExpr Expr]
is
          Bool
-> IExpr
-> [IndexExpr Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugarIndexedExpr Bool
False IExpr
expr'' [IndexExpr Expr]
indices'
    desugarMultiScript :: t
-> t
-> (t -> t -> IExpr -> b)
-> Bool
-> Expr
-> IndexExpr Expr
-> IndexExpr Expr
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
desugarMultiScript t
override t
expr' t -> t -> IExpr -> b
refExpr Bool
override1 Expr
e1 IndexExpr Expr
n1 IndexExpr Expr
n2 = do
      String
k     <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      IExpr
n1'   <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (IndexExpr Expr -> Expr
forall a. IndexExpr a -> a
extractIndexExpr IndexExpr Expr
n1)
      IExpr
n2'   <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (IndexExpr Expr -> Expr
forall a. IndexExpr a -> a
extractIndexExpr IndexExpr Expr
n2)
      IExpr
e1'   <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
e1
      b -> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> StateT EvalState (ExceptT EgisonError RuntimeM) b)
-> b -> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall a b. (a -> b) -> a -> b
$ t -> t -> IExpr -> b
refExpr t
override t
expr' (String -> [IExpr] -> IExpr
makeIApply String
"map"
                                           [Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing [String -> Var
stringToVar String
k] (Bool -> IExpr -> [Index IExpr] -> IExpr
IIndexedExpr Bool
override1 IExpr
e1' [IExpr -> Index IExpr
forall a. a -> Index a
Sub (String -> IExpr
IVarExpr String
k)]),
                                            String -> [IExpr] -> IExpr
makeIApply String
"between" [IExpr
n1', IExpr
n2']])
    isMulti :: IndexExpr a -> Bool
isMulti (MultiSubscript a
_ a
_)   = Bool
True
    isMulti (MultiSuperscript a
_ a
_) = Bool
True
    isMulti IndexExpr a
_                      = Bool
False


desugar (SubrefsExpr Bool
bool Expr
expr1 Expr
expr2) =
  Bool -> IExpr -> IExpr -> IExpr
ISubrefsExpr Bool
bool (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2

desugar (SuprefsExpr Bool
bool Expr
expr1 Expr
expr2) =
  Bool -> IExpr -> IExpr -> IExpr
ISuprefsExpr Bool
bool (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2

desugar (UserrefsExpr Bool
bool Expr
expr1 Expr
expr2) =
  Bool -> IExpr -> IExpr -> IExpr
IUserrefsExpr Bool
bool (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2

desugar (TupleExpr [Expr]
exprs) = [IExpr] -> IExpr
ITupleExpr ([IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
exprs
desugar (CollectionExpr [Expr]
xs) = [IExpr] -> IExpr
ICollectionExpr ([IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
xs
desugar (ConsExpr Expr
x Expr
xs) = IExpr -> IExpr -> IExpr
IConsExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
x StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
xs
desugar (JoinExpr Expr
x Expr
xs) = IExpr -> IExpr -> IExpr
IJoinExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
x StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
xs

desugar (HashExpr [(Expr, Expr)]
exprPairs) =
  [(IExpr, IExpr)] -> IExpr
IHashExpr ([(IExpr, IExpr)] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [(IExpr, IExpr)]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Expr, Expr)
 -> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr, IExpr))
-> [(Expr, Expr)]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [(IExpr, IExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Expr
expr1, Expr
expr2) -> (,) (IExpr -> IExpr -> (IExpr, IExpr))
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IExpr -> (IExpr, IExpr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IExpr -> (IExpr, IExpr))
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr, IExpr)
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2) [(Expr, Expr)]
exprPairs

desugar (VectorExpr [Expr]
exprs) =
  [IExpr] -> IExpr
IVectorExpr ([IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
exprs

desugar (TensorExpr Expr
nsExpr Expr
xsExpr) =
  IExpr -> IExpr -> IExpr
ITensorExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
nsExpr StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
xsExpr

-- Desugar of LambdaExpr takes place in 2 stages.
-- * LambdaExpr -> LambdaExpr'  : Desugar pattern matches at the arg positions
-- * LambdaExpr' -> ILambdaExpr : Desugar Arg and InvertedArg
desugar (LambdaExpr [Arg ArgPattern]
args Expr
expr) = do
  ([Arg VarWithIndices]
args', Expr
expr') <- (Arg ArgPattern
 -> ([Arg VarWithIndices], Expr)
 -> StateT
      EvalState
      (ExceptT EgisonError RuntimeM)
      ([Arg VarWithIndices], Expr))
-> ([Arg VarWithIndices], Expr)
-> [Arg ArgPattern]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Arg VarWithIndices], Expr)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Arg ArgPattern
-> ([Arg VarWithIndices], Expr)
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Arg VarWithIndices], Expr)
desugarArg ([], Expr
expr) [Arg ArgPattern]
args
  Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [Arg VarWithIndices] -> Expr -> Expr
LambdaExpr' [Arg VarWithIndices]
args' Expr
expr'
  where
    desugarArg :: Arg ArgPattern -> ([Arg VarWithIndices], Expr) -> EvalM ([Arg VarWithIndices], Expr)
    desugarArg :: Arg ArgPattern
-> ([Arg VarWithIndices], Expr)
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Arg VarWithIndices], Expr)
desugarArg (Arg ArgPattern
x) ([Arg VarWithIndices]
args, Expr
expr) = do
      (VarWithIndices
var, Expr
expr') <- ArgPattern -> Expr -> EvalM (VarWithIndices, Expr)
desugarArgPat ArgPattern
x Expr
expr
      ([Arg VarWithIndices], Expr)
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Arg VarWithIndices], Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices -> Arg VarWithIndices
forall a. a -> Arg a
Arg VarWithIndices
var Arg VarWithIndices -> [Arg VarWithIndices] -> [Arg VarWithIndices]
forall a. a -> [a] -> [a]
: [Arg VarWithIndices]
args, Expr
expr')
    desugarArg (InvertedArg ArgPattern
x) ([Arg VarWithIndices]
args, Expr
expr) = do
      (VarWithIndices
var, Expr
expr') <- ArgPattern -> Expr -> EvalM (VarWithIndices, Expr)
desugarArgPat ArgPattern
x Expr
expr
      ([Arg VarWithIndices], Expr)
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Arg VarWithIndices], Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices -> Arg VarWithIndices
forall a. a -> Arg a
InvertedArg VarWithIndices
var Arg VarWithIndices -> [Arg VarWithIndices] -> [Arg VarWithIndices]
forall a. a -> [a] -> [a]
: [Arg VarWithIndices]
args, Expr
expr')

    -- Desugar argument patterns. Examples:
    -- \$(%x, %y) -> expr   ==> \$tmp -> let (tmp1, tmp2) := tmp in (\%x %y -> expr) tmp1 tmp2
    -- \(x, (y, z)) -> expr ==> \tmp  -> let (tmp1, tmp2) := tmp in (\x (y, z) -> expr) tmp1 tmp2
    -- \%($x :: xs) -> expr ==> \%tmp -> let (tmp1 :: xs) := tmp in (\$x %xs -> expr) tmp1 tmp2
    desugarArgPat :: ArgPattern -> Expr -> EvalM (VarWithIndices, Expr)
    desugarArgPat :: ArgPattern -> Expr -> EvalM (VarWithIndices, Expr)
desugarArgPat ArgPattern
APWildCard Expr
expr = do
      String
tmp <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      let tmp' :: VarWithIndices
tmp' = String -> VarWithIndices
stringToVarWithIndices String
tmp
      (VarWithIndices, Expr) -> EvalM (VarWithIndices, Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices
tmp', [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind PrimitiveDataPattern
forall var. PDPatternBase var
PDWildCard (String -> Expr
VarExpr String
tmp)] Expr
expr)
    desugarArgPat (APPatVar VarWithIndices
var) Expr
expr = (VarWithIndices, Expr) -> EvalM (VarWithIndices, Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices
var, Expr
expr)
    desugarArgPat (APTuplePat [Arg ArgPattern]
args) Expr
expr = do
      String
tmp  <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      let tmp' :: VarWithIndices
tmp' = String -> VarWithIndices
stringToVarWithIndices String
tmp
      [String]
tmps <- (Arg ArgPattern
 -> StateT EvalState (ExceptT EgisonError RuntimeM) String)
-> [Arg ArgPattern]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT EvalState (ExceptT EgisonError RuntimeM) String
-> Arg ArgPattern
-> StateT EvalState (ExceptT EgisonError RuntimeM) String
forall a b. a -> b -> a
const StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh) [Arg ArgPattern]
args
      (VarWithIndices, Expr) -> EvalM (VarWithIndices, Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices
tmp', [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind ([PrimitiveDataPattern] -> PrimitiveDataPattern
forall var. [PDPatternBase var] -> PDPatternBase var
PDTuplePat ((String -> PrimitiveDataPattern)
-> [String] -> [PrimitiveDataPattern]
forall a b. (a -> b) -> [a] -> [b]
map String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar [String]
tmps)) (String -> Expr
VarExpr String
tmp)]
                      (Expr -> [Expr] -> Expr
ApplyExpr ([Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern]
args Expr
expr) ((String -> Expr) -> [String] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
VarExpr [String]
tmps)))
    desugarArgPat (APInductivePat String
ctor [Arg ArgPattern]
args) Expr
expr = do
      String
tmp  <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      let tmp' :: VarWithIndices
tmp' = String -> VarWithIndices
stringToVarWithIndices String
tmp
      [String]
tmps <- (Arg ArgPattern
 -> StateT EvalState (ExceptT EgisonError RuntimeM) String)
-> [Arg ArgPattern]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT EvalState (ExceptT EgisonError RuntimeM) String
-> Arg ArgPattern
-> StateT EvalState (ExceptT EgisonError RuntimeM) String
forall a b. a -> b -> a
const StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh) [Arg ArgPattern]
args
      (VarWithIndices, Expr) -> EvalM (VarWithIndices, Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices
tmp', [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind (String -> [PrimitiveDataPattern] -> PrimitiveDataPattern
forall var. String -> [PDPatternBase var] -> PDPatternBase var
PDInductivePat String
ctor ((String -> PrimitiveDataPattern)
-> [String] -> [PrimitiveDataPattern]
forall a b. (a -> b) -> [a] -> [b]
map String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar [String]
tmps)) (String -> Expr
VarExpr String
tmp)]
                      (Expr -> [Expr] -> Expr
ApplyExpr ([Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern]
args Expr
expr) ((String -> Expr) -> [String] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
VarExpr [String]
tmps)))
    desugarArgPat ArgPattern
APEmptyPat Expr
expr = do
      String
tmp <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      let tmp' :: VarWithIndices
tmp' = String -> VarWithIndices
stringToVarWithIndices String
tmp
      (VarWithIndices, Expr) -> EvalM (VarWithIndices, Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices
tmp', [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind PrimitiveDataPattern
forall var. PDPatternBase var
PDEmptyPat (String -> Expr
VarExpr String
tmp)] Expr
expr)
    desugarArgPat (APConsPat Arg ArgPattern
arg1 ArgPattern
arg2) Expr
expr = do
      String
tmp  <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      let tmp' :: VarWithIndices
tmp' = String -> VarWithIndices
stringToVarWithIndices String
tmp
      String
tmp1 <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      String
tmp2 <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      (VarWithIndices, Expr) -> EvalM (VarWithIndices, Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices
tmp', [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind (PrimitiveDataPattern
-> PrimitiveDataPattern -> PrimitiveDataPattern
forall var.
PDPatternBase var -> PDPatternBase var -> PDPatternBase var
PDConsPat (String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
tmp1) (String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
tmp2)) (String -> Expr
VarExpr String
tmp)]
                     (Expr -> [Expr] -> Expr
ApplyExpr ([Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern
arg1, ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg ArgPattern
arg2] Expr
expr) [String -> Expr
VarExpr String
tmp1, String -> Expr
VarExpr String
tmp2]))
    desugarArgPat (APSnocPat ArgPattern
arg1 Arg ArgPattern
arg2) Expr
expr = do
      String
tmp  <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      let tmp' :: VarWithIndices
tmp' = String -> VarWithIndices
stringToVarWithIndices String
tmp
      String
tmp1 <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      String
tmp2 <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
      (VarWithIndices, Expr) -> EvalM (VarWithIndices, Expr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarWithIndices
tmp', [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind (PrimitiveDataPattern
-> PrimitiveDataPattern -> PrimitiveDataPattern
forall var.
PDPatternBase var -> PDPatternBase var -> PDPatternBase var
PDSnocPat (String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
tmp1) (String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
tmp2)) (String -> Expr
VarExpr String
tmp)]
                     (Expr -> [Expr] -> Expr
ApplyExpr ([Arg ArgPattern] -> Expr -> Expr
LambdaExpr [ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg ArgPattern
arg1, Arg ArgPattern
arg2] Expr
expr) [String -> Expr
VarExpr String
tmp1, String -> Expr
VarExpr String
tmp2]))

desugar (LambdaExpr' [Arg VarWithIndices]
vwis Expr
expr) = do
  let ([VarWithIndices]
vwis', Expr
expr') = (Arg VarWithIndices
 -> ([VarWithIndices], Expr) -> ([VarWithIndices], Expr))
-> ([VarWithIndices], Expr)
-> [Arg VarWithIndices]
-> ([VarWithIndices], Expr)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Arg VarWithIndices
-> ([VarWithIndices], Expr) -> ([VarWithIndices], Expr)
desugarInvertedArgs ([], Expr
expr) [Arg VarWithIndices]
vwis
  let args' :: [Var]
args' = (VarWithIndices -> Var) -> [VarWithIndices] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map VarWithIndices -> Var
varWithIndicesToVar [VarWithIndices]
vwis'
  IExpr
expr' <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr'
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing [Var]
args' IExpr
expr'
  where
    desugarInvertedArgs :: Arg VarWithIndices -> ([VarWithIndices], Expr) -> ([VarWithIndices], Expr)
    desugarInvertedArgs :: Arg VarWithIndices
-> ([VarWithIndices], Expr) -> ([VarWithIndices], Expr)
desugarInvertedArgs (Arg VarWithIndices
x) ([VarWithIndices]
args, Expr
expr) = (VarWithIndices
x VarWithIndices -> [VarWithIndices] -> [VarWithIndices]
forall a. a -> [a] -> [a]
: [VarWithIndices]
args, Expr
expr)
    desugarInvertedArgs (InvertedArg VarWithIndices
x) ([VarWithIndices]
args, Expr
expr) =
      let varName :: String
varName = VarWithIndices -> String
extractNameFromVarWithIndices VarWithIndices
x
          flippedExpr :: Expr
flippedExpr = Expr -> Expr
FlipIndicesExpr (String -> Expr
VarExpr String
varName)
          bindPat :: PrimitiveDataPattern
bindPat = String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
varName
      in (VarWithIndices
x VarWithIndices -> [VarWithIndices] -> [VarWithIndices]
forall a. a -> [a] -> [a]
: [VarWithIndices]
args, [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind PrimitiveDataPattern
bindPat Expr
flippedExpr] Expr
expr)

desugar (MemoizedLambdaExpr [String]
names Expr
expr) =
  [String] -> IExpr -> IExpr
IMemoizedLambdaExpr [String]
names (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

-- Typed memoized lambda is desugared the same way (type info used only for type checking)
desugar (TypedMemoizedLambdaExpr [TypedParam]
params TypeExpr
_ Expr
body) =
  [String] -> IExpr -> IExpr
IMemoizedLambdaExpr ([TypedParam] -> [String]
extractParamNames [TypedParam]
params) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
body
  where
    extractParamNames :: [TypedParam] -> [String]
extractParamNames = (TypedParam -> [String]) -> [TypedParam] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedParam -> [String]
extractName
    extractName :: TypedParam -> [String]
extractName (TPVar String
name TypeExpr
_) = [String
name]
    extractName (TPInvertedVar String
name TypeExpr
_) = [String
name]
    extractName (TPTuple [TypedParam]
elems) = (TypedParam -> [String]) -> [TypedParam] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedParam -> [String]
extractName [TypedParam]
elems
    extractName (TPWildcard TypeExpr
_) = []
    extractName (TPUntypedVar String
name) = [String
name]
    extractName TypedParam
TPUntypedWildcard = []

desugar (CambdaExpr String
name Expr
expr) =
  String -> IExpr -> IExpr
ICambdaExpr String
name (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (PatternFunctionExpr [String]
_names Pattern
_pattern) =
  -- Pattern functions are only defined at TopExpr level
  -- They should not appear in expression context
  EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a.
EgisonError -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EgisonError
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> EgisonError
Default String
"Pattern functions cannot be used as expressions"

desugar (IfExpr Expr
expr0 Expr
expr1 Expr
expr2) =
  IExpr -> IExpr -> IExpr -> IExpr
IIfExpr (IExpr -> IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr0 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2

desugar (LetExpr [BindingExpr]
binds Expr
expr) =
  [IBindingExpr] -> IExpr -> IExpr
ILetExpr ([IBindingExpr] -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
desugarBindings [BindingExpr]
binds StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (LetRecExpr [BindingExpr]
binds Expr
expr) =
  [IBindingExpr] -> IExpr -> IExpr
ILetRecExpr ([IBindingExpr] -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
desugarBindings [BindingExpr]
binds StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (WithSymbolsExpr [String]
vars Expr
expr) =
  [String] -> IExpr -> IExpr
IWithSymbolsExpr [String]
vars (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (MatchExpr PMMode
pmmode Expr
expr0 Expr
expr1 [MatchClause]
clauses) =
  PMMode -> IExpr -> IExpr -> [IMatchClause] -> IExpr
IMatchExpr PMMode
pmmode (IExpr -> IExpr -> [IMatchClause] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     (IExpr -> [IMatchClause] -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr0 StateT
  EvalState
  (ExceptT EgisonError RuntimeM)
  (IExpr -> [IMatchClause] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IMatchClause] -> IExpr)
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT
  EvalState (ExceptT EgisonError RuntimeM) ([IMatchClause] -> IExpr)
-> EvalM [IMatchClause]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [MatchClause] -> EvalM [IMatchClause]
desugarMatchClauses [MatchClause]
clauses

desugar (MatchAllExpr PMMode
pmmode Expr
expr0 Expr
expr1 [MatchClause]
clauses) =
  PMMode -> IExpr -> IExpr -> [IMatchClause] -> IExpr
IMatchAllExpr PMMode
pmmode (IExpr -> IExpr -> [IMatchClause] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     (IExpr -> [IMatchClause] -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr0 StateT
  EvalState
  (ExceptT EgisonError RuntimeM)
  (IExpr -> [IMatchClause] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IMatchClause] -> IExpr)
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT
  EvalState (ExceptT EgisonError RuntimeM) ([IMatchClause] -> IExpr)
-> EvalM [IMatchClause]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [MatchClause] -> EvalM [IMatchClause]
desugarMatchClauses [MatchClause]
clauses

desugar (DoExpr [BindingExpr]
binds Expr
expr) =
  [IBindingExpr] -> IExpr -> IExpr
IDoExpr ([IBindingExpr] -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
desugarBindings [BindingExpr]
binds StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (PrefixExpr String
"-" Expr
expr) = do
  IExpr
expr' <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> [IExpr] -> IExpr
makeIApply String
"*" [ConstantExpr -> IExpr
IConstantExpr (Integer -> ConstantExpr
IntegerExpr (-Integer
1)), IExpr
expr']
desugar (PrefixExpr String
"!" (ApplyExpr Expr
expr [Expr]
args)) =
  IExpr -> [IExpr] -> IExpr
IWedgeApplyExpr (IExpr -> [IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr StateT EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
args
desugar (PrefixExpr String
"'" Expr
expr) = IExpr -> IExpr
IQuoteExpr (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
desugar (PrefixExpr String
"`" Expr
expr) = IExpr -> IExpr
IQuoteSymbolExpr (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
desugar (PrefixExpr String
op Expr
_) = String -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a.
String -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown prefix " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op)

desugar (InfixExpr Op
op Expr
expr1 Expr
expr2) | Op -> Bool
isWedge Op
op =
  (\IExpr
x IExpr
y -> IExpr -> [IExpr] -> IExpr
IWedgeApplyExpr (String -> IExpr
IVarExpr (Op -> String
repr Op
op)) [IExpr
x, IExpr
y])
    (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2

desugar (InfixExpr Op
op Expr
expr1 Expr
expr2) | Op -> String
repr Op
op String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"::" =
  IExpr -> IExpr -> IExpr
IConsExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2
desugar (InfixExpr Op
op Expr
expr1 Expr
expr2) | Op -> String
repr Op
op String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"++" =
  IExpr -> IExpr -> IExpr
IJoinExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2
desugar (InfixExpr Op
op Expr
expr1 Expr
expr2) =
  (\IExpr
x IExpr
y -> String -> [IExpr] -> IExpr
makeIApply (Op -> String
repr Op
op) [IExpr
x, IExpr
y]) (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr2

-- section
--
-- If `op` is not a cambda, simply desugar it into the function
desugar (SectionExpr Op
op Maybe Expr
Nothing Maybe Expr
Nothing)
  | Bool -> Bool
not (Op -> Bool
isWedge Op
op Bool -> Bool -> Bool
|| Op -> String
repr Op
op String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"::", String
"++"]) =
    Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (String -> Expr
VarExpr (Op -> String
repr Op
op))
desugar (SectionExpr Op
op Maybe Expr
Nothing Maybe Expr
Nothing) = do
  String
x <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  String
y <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing [String -> Var
stringToVar String
x, String -> Var
stringToVar String
y] (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Op -> Expr -> Expr -> Expr
InfixExpr Op
op (String -> Expr
VarExpr String
x) (String -> Expr
VarExpr String
y))

desugar (SectionExpr Op
op Maybe Expr
Nothing (Just Expr
expr2)) = do
  String
x <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing [String -> Var
stringToVar String
x] (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Op -> Expr -> Expr -> Expr
InfixExpr Op
op (String -> Expr
VarExpr String
x) Expr
expr2)

desugar (SectionExpr Op
op (Just Expr
expr1) Maybe Expr
Nothing) = do
  String
y <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr Maybe Var
forall a. Maybe a
Nothing [String -> Var
stringToVar String
y] (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Op -> Expr -> Expr -> Expr
InfixExpr Op
op Expr
expr1 (String -> Expr
VarExpr String
y))

desugar SectionExpr{} = EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a.
EgisonError -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EgisonError
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> EgisonError
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> EgisonError
Default String
"Cannot reach here: section with both arguments"

desugar (SeqExpr Expr
expr0 Expr
expr1) =
  IExpr -> IExpr -> IExpr
ISeqExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr0 StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr1

desugar (GenerateTensorExpr Expr
fnExpr Expr
sizeExpr) =
  IExpr -> IExpr -> IExpr
IGenerateTensorExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
fnExpr StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
sizeExpr

desugar (TensorContractExpr Expr
tExpr) =
  IExpr -> IExpr
ITensorContractExpr (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
tExpr

desugar (TensorMapExpr (LambdaExpr' [Arg VarWithIndices
x] (TensorMapExpr (LambdaExpr' [Arg VarWithIndices
y] Expr
expr) Expr
b)) Expr
a) =
  Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> Expr -> Expr -> Expr
TensorMap2Expr ([Arg VarWithIndices] -> Expr -> Expr
LambdaExpr' [Arg VarWithIndices
x, Arg VarWithIndices
y] Expr
expr) Expr
a Expr
b)
desugar (TensorMapExpr (LambdaExpr [Arg ArgPattern
x] (TensorMapExpr (LambdaExpr [Arg ArgPattern
y] Expr
expr) Expr
b)) Expr
a) =
  Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> Expr -> Expr -> Expr
TensorMap2Expr ([Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern
x, Arg ArgPattern
y] Expr
expr) Expr
a Expr
b)

desugar (TensorMapExpr Expr
fnExpr Expr
tExpr) =
  IExpr -> IExpr -> IExpr
ITensorMapExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
fnExpr StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
tExpr

desugar (TensorMap2Expr Expr
fnExpr Expr
t1Expr Expr
t2Expr) =
  IExpr -> IExpr -> IExpr -> IExpr
ITensorMap2Expr (IExpr -> IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
fnExpr StateT
  EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
t1Expr StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
t2Expr

desugar (TransposeExpr Expr
vars Expr
expr) =
  -- ITransposeExpr takes (permutation, tensor) as arguments to match tTranspose
  IExpr -> IExpr -> IExpr
ITransposeExpr (IExpr -> IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
vars StateT EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (FlipIndicesExpr Expr
expr) =
  IExpr -> IExpr
IFlipIndicesExpr (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (ApplyExpr Expr
expr [Expr]
args) =
  IExpr -> [IExpr] -> IExpr
IApplyExpr (IExpr -> [IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr StateT EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
args

desugar Expr
FreshVarExpr = do
  String
id <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> IExpr
IVarExpr (String
":::" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
id)

desugar (MatcherExpr [PatternDef]
patternDefs) =
  [(PrimitivePatPattern, IExpr, [IBindingExpr])] -> IExpr
IMatcherExpr ([(PrimitivePatPattern, IExpr, [IBindingExpr])] -> IExpr)
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(PrimitivePatPattern, IExpr, [IBindingExpr])]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PatternDef -> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr]))
-> [PatternDef]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(PrimitivePatPattern, IExpr, [IBindingExpr])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PatternDef -> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
desugarPatternDef [PatternDef]
patternDefs

desugar (AnonParamExpr Integer
n) = IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ String -> IExpr
IVarExpr (Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: Integer -> String
forall a. Show a => a -> String
show Integer
n)

desugar (AnonParamFuncExpr Integer
n Expr
expr) = do
  let args :: [VarWithIndices]
args = (Integer -> VarWithIndices) -> [Integer] -> [VarWithIndices]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
n -> String -> VarWithIndices
stringToVarWithIndices (Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: Integer -> String
forall a. Show a => a -> String
show Integer
n)) [Integer
1..Integer
n]
  IExpr
lambda <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [Arg VarWithIndices] -> Expr -> Expr
LambdaExpr' ((VarWithIndices -> Arg VarWithIndices)
-> [VarWithIndices] -> [Arg VarWithIndices]
forall a b. (a -> b) -> [a] -> [b]
map VarWithIndices -> Arg VarWithIndices
forall a. a -> Arg a
Arg [VarWithIndices]
args) Expr
expr
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [IBindingExpr] -> IExpr -> IExpr
ILetRecExpr [(Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
"%0"), IExpr
lambda)] (String -> IExpr
IVarExpr String
"%0")

desugar (AnonTupleParamFuncExpr Integer
1 Expr
expr) = do
  IExpr
lambda <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [Arg VarWithIndices] -> Expr -> Expr
LambdaExpr' [VarWithIndices -> Arg VarWithIndices
forall a. a -> Arg a
Arg (String -> VarWithIndices
stringToVarWithIndices String
"%1")] Expr
expr
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [IBindingExpr] -> IExpr -> IExpr
ILetRecExpr [(Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
"%0"), IExpr
lambda)] (String -> IExpr
IVarExpr String
"%0")
desugar (AnonTupleParamFuncExpr Integer
n Expr
expr) = do
  let args :: [VarWithIndices]
args = (Integer -> VarWithIndices) -> [Integer] -> [VarWithIndices]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
n -> String -> VarWithIndices
stringToVarWithIndices (Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: Integer -> String
forall a. Show a => a -> String
show Integer
n)) [Integer
1..Integer
n]
  IExpr
lambda <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$
    [Arg ArgPattern] -> Expr -> Expr
LambdaExpr [ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg ([Arg ArgPattern] -> ArgPattern
APTuplePat ([Arg ArgPattern] -> ArgPattern) -> [Arg ArgPattern] -> ArgPattern
forall a b. (a -> b) -> a -> b
$ (VarWithIndices -> Arg ArgPattern)
-> [VarWithIndices] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map (ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (ArgPattern -> Arg ArgPattern)
-> (VarWithIndices -> ArgPattern)
-> VarWithIndices
-> Arg ArgPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarWithIndices -> ArgPattern
APPatVar) [VarWithIndices]
args)] Expr
expr
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [IBindingExpr] -> IExpr -> IExpr
ILetRecExpr [(Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
"%0"), IExpr
lambda)] (String -> IExpr
IVarExpr String
"%0")

desugar (AnonListParamFuncExpr Integer
n Expr
expr) = do
  let args' :: [Arg ArgPattern]
args' = (Integer -> Arg ArgPattern) -> [Integer] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
n -> ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (VarWithIndices -> ArgPattern
APPatVar (String -> VarWithIndices
stringToVarWithIndices (Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: Integer -> String
forall a. Show a => a -> String
show Integer
n)))) [Integer
1..Integer
n]
  let args :: ArgPattern
args = (Arg ArgPattern -> ArgPattern -> ArgPattern)
-> ArgPattern -> [Arg ArgPattern] -> ArgPattern
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Arg ArgPattern -> ArgPattern -> ArgPattern
APConsPat ArgPattern
APEmptyPat [Arg ArgPattern]
args'
  IExpr
lambda <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [Arg ArgPattern] -> Expr -> Expr
LambdaExpr [ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg ArgPattern
args] Expr
expr
  IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [IBindingExpr] -> IExpr -> IExpr
ILetRecExpr [(Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
"%0"), IExpr
lambda)] (String -> IExpr
IVarExpr String
"%0")

desugar (QuoteExpr Expr
expr) =
  IExpr -> IExpr
IQuoteExpr (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (QuoteSymbolExpr Expr
expr) =
  IExpr -> IExpr
IQuoteSymbolExpr (IExpr -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

desugar (WedgeApplyExpr Expr
expr [Expr]
args) =
  IExpr -> [IExpr] -> IExpr
IWedgeApplyExpr (IExpr -> [IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr StateT EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
args

desugar (FunctionExpr [String]
args) = IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> IExpr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [String] -> IExpr
IFunctionExpr [String]
args

-- Type annotation is erased at runtime
desugar (TypeAnnotation Expr
expr TypeExpr
_typeExpr) = Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr

-- Typed lambda is desugared to regular lambda
desugar (TypedLambdaExpr [(String, TypeExpr)]
params TypeExpr
_retType Expr
body) = do
  let args :: [Arg ArgPattern]
args = ((String, TypeExpr) -> Arg ArgPattern)
-> [(String, TypeExpr)] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
name, TypeExpr
_) -> ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (VarWithIndices -> ArgPattern
APPatVar (String -> [VarIndex] -> VarWithIndices
VarWithIndices String
name []))) [(String, TypeExpr)]
params
  Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
forall a b. (a -> b) -> a -> b
$ [Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern]
args Expr
body

desugarIndex :: IndexExpr Expr -> EvalM (Index IExpr)
desugarIndex :: IndexExpr Expr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr)
desugarIndex (Subscript Expr
e)    = IExpr -> Index IExpr
forall a. a -> Index a
Sub (IExpr -> Index IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
e
desugarIndex (Superscript Expr
e)  = IExpr -> Index IExpr
forall a. a -> Index a
Sup (IExpr -> Index IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
e
desugarIndex (SupSubscript Expr
e) = IExpr -> Index IExpr
forall a. a -> Index a
SupSub (IExpr -> Index IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
e
desugarIndex (Userscript Expr
e)   = IExpr -> Index IExpr
forall a. a -> Index a
User (IExpr -> Index IExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
e
desugarIndex IndexExpr Expr
_                = StateT EvalState (ExceptT EgisonError RuntimeM) (Index IExpr)
forall a. HasCallStack => a
undefined

desugarPattern :: Pattern -> EvalM IPattern
desugarPattern :: Pattern -> EvalM IPattern
desugarPattern Pattern
pat =
  case Pattern -> [String]
collectName Pattern
pat of
    []    -> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat
    [String]
names -> [IBindingExpr] -> IPattern -> IPattern
ILetPat ((String -> IBindingExpr) -> [String] -> [IBindingExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> IBindingExpr
makeBinding [String]
names) (IPattern -> IPattern) -> EvalM IPattern -> EvalM IPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat
 where
   collectNames :: [Pattern] -> [String]
   collectNames :: [Pattern] -> [String]
collectNames [Pattern]
pats = ([String] -> [String] -> [String])
-> [String] -> [[String]] -> [String]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
union [] ((Pattern -> [String]) -> [Pattern] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Pattern -> [String]
collectName [Pattern]
pats)

   collectName :: Pattern -> [String]
   collectName :: Pattern -> [String]
collectName (ForallPat Pattern
pat1 Pattern
pat2)                           = Pattern -> [String]
collectName Pattern
pat1 [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` Pattern -> [String]
collectName Pattern
pat2
   collectName (InfixPat Op
_ Pattern
pat1 Pattern
pat2)                          = Pattern -> [String]
collectName Pattern
pat1 [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` Pattern -> [String]
collectName Pattern
pat2
   collectName (NotPat Pattern
pat)                                    = Pattern -> [String]
collectName Pattern
pat
   collectName (AndPat Pattern
pat1 Pattern
pat2)                              = Pattern -> [String]
collectName Pattern
pat1 [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` Pattern -> [String]
collectName Pattern
pat2
   collectName (OrPat Pattern
pat1 Pattern
pat2)                               = Pattern -> [String]
collectName Pattern
pat1 [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` Pattern -> [String]
collectName Pattern
pat2
   collectName (TuplePat [Pattern]
pats)                                 = [Pattern] -> [String]
collectNames [Pattern]
pats
   collectName (InductiveOrPApplyPat String
_ [Pattern]
pats)                   = [Pattern] -> [String]
collectNames [Pattern]
pats
   collectName (InductivePat String
_ [Pattern]
pats)                           = [Pattern] -> [String]
collectNames [Pattern]
pats
   collectName (PApplyPat Expr
_ [Pattern]
pats)                              = [Pattern] -> [String]
collectNames [Pattern]
pats
   collectName (DApplyPat Pattern
_ [Pattern]
pats)                              = [Pattern] -> [String]
collectNames [Pattern]
pats
   collectName (LoopPat String
_ (LoopRange Expr
_ Expr
_ Pattern
endNumPat) Pattern
pat1 Pattern
pat2) = Pattern -> [String]
collectName Pattern
endNumPat [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` Pattern -> [String]
collectName Pattern
pat1 [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` Pattern -> [String]
collectName Pattern
pat2
   collectName (LetPat [BindingExpr]
_ Pattern
pat)                                  = Pattern -> [String]
collectName Pattern
pat
   collectName (IndexedPat (PatVar String
var) [Expr]
_)                     = [String
var]
   collectName Pattern
_                                               = []

   makeBinding :: String -> IBindingExpr
   makeBinding :: String -> IBindingExpr
makeBinding String
var = (Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> Var
stringToVar String
var), [(IExpr, IExpr)] -> IExpr
IHashExpr [])

desugarPattern' :: Pattern -> EvalM IPattern
desugarPattern' :: Pattern -> EvalM IPattern
desugarPattern' Pattern
WildCard        = IPattern -> EvalM IPattern
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return IPattern
IWildCard
desugarPattern' Pattern
ContPat         = IPattern -> EvalM IPattern
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return IPattern
IContPat
desugarPattern' Pattern
SeqNilPat       = IPattern -> EvalM IPattern
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return IPattern
ISeqNilPat
desugarPattern' Pattern
LaterPatVar     = IPattern -> EvalM IPattern
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return IPattern
ILaterPatVar
desugarPattern' (VarPat String
v)      = IPattern -> EvalM IPattern
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IPattern
IVarPat String
v)
desugarPattern' (PatVar String
var)    = IPattern -> EvalM IPattern
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IPattern
IPatVar String
var)
desugarPattern' (ValuePat Expr
expr) = IExpr -> IPattern
IValuePat (IExpr -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> EvalM IPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
desugarPattern' (PredPat Expr
expr)  = IExpr -> IPattern
IPredPat (IExpr -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> EvalM IPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
desugarPattern' (NotPat Pattern
pat)       = IPattern -> IPattern
INotPat (IPattern -> IPattern) -> EvalM IPattern -> EvalM IPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat
desugarPattern' (AndPat Pattern
pat1 Pattern
pat2) = IPattern -> IPattern -> IPattern
IAndPat (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2
desugarPattern' (OrPat Pattern
pat1 Pattern
pat2)  = IPattern -> IPattern -> IPattern
IOrPat (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2
desugarPattern' (ForallPat Pattern
pat1 Pattern
pat2) = IPattern -> IPattern -> IPattern
IForallPat (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2
desugarPattern' (InfixPat Op{ repr :: Op -> String
repr = String
"&" } Pattern
pat1 Pattern
pat2) =
  IPattern -> IPattern -> IPattern
IAndPat (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2
desugarPattern' (InfixPat Op{ repr :: Op -> String
repr = String
"|" } Pattern
pat1 Pattern
pat2) =
  IPattern -> IPattern -> IPattern
IOrPat (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2
desugarPattern' (InfixPat Op{ repr :: Op -> String
repr = String
f } Pattern
pat1 Pattern
pat2) =
  (\IPattern
x IPattern
y -> String -> [IPattern] -> IPattern
IInductivePat String
f [IPattern
x, IPattern
y]) (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2
desugarPattern' (TuplePat [Pattern]
pats) = [IPattern] -> IPattern
ITuplePat ([IPattern] -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
-> EvalM IPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern -> EvalM IPattern)
-> [Pattern]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pattern -> EvalM IPattern
desugarPattern' [Pattern]
pats
desugarPattern' (InductiveOrPApplyPat String
name [Pattern]
pats) = String -> [IPattern] -> IPattern
IInductiveOrPApplyPat String
name ([IPattern] -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
-> EvalM IPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern -> EvalM IPattern)
-> [Pattern]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pattern -> EvalM IPattern
desugarPattern' [Pattern]
pats
-- Convert all InductivePat to IInductiveOrPApplyPat since we cannot distinguish between
-- pattern constructors and pattern functions at parse time
desugarPattern' (InductivePat String
name [Pattern]
pats) = String -> [IPattern] -> IPattern
IInductiveOrPApplyPat String
name ([IPattern] -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
-> EvalM IPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern -> EvalM IPattern)
-> [Pattern]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pattern -> EvalM IPattern
desugarPattern' [Pattern]
pats
desugarPattern' (IndexedPat Pattern
pat [Expr]
exprs) = IPattern -> [IExpr] -> IPattern
IIndexedPat (IPattern -> [IExpr] -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat StateT
  EvalState (ExceptT EgisonError RuntimeM) ([IExpr] -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
-> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr)
-> [Expr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar [Expr]
exprs
desugarPattern' (PApplyPat Expr
expr [Pattern]
pats) = IExpr -> [IPattern] -> IPattern
IPApplyPat (IExpr -> [IPattern] -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IPattern] -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr StateT
  EvalState (ExceptT EgisonError RuntimeM) ([IPattern] -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
-> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern -> EvalM IPattern)
-> [Pattern]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pattern -> EvalM IPattern
desugarPattern' [Pattern]
pats
desugarPattern' (DApplyPat Pattern
pat [Pattern]
pats) = IPattern -> [IPattern] -> IPattern
IDApplyPat (IPattern -> [IPattern] -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) ([IPattern] -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat StateT
  EvalState (ExceptT EgisonError RuntimeM) ([IPattern] -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
-> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern -> EvalM IPattern)
-> [Pattern]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pattern -> EvalM IPattern
desugarPattern' [Pattern]
pats
desugarPattern' (LoopPat String
name LoopRange
range Pattern
pat1 Pattern
pat2) = String -> ILoopRange -> IPattern -> IPattern -> IPattern
ILoopPat String
name (ILoopRange -> IPattern -> IPattern -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) ILoopRange
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     (IPattern -> IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoopRange
-> StateT EvalState (ExceptT EgisonError RuntimeM) ILoopRange
desugarLoopRange LoopRange
range StateT
  EvalState
  (ExceptT EgisonError RuntimeM)
  (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2
desugarPattern' (LetPat [BindingExpr]
binds Pattern
pat) = [IBindingExpr] -> IPattern -> IPattern
ILetPat ([IBindingExpr] -> IPattern -> IPattern)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
desugarBindings [BindingExpr]
binds StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat
desugarPattern' (SeqConsPat Pattern
pat1 Pattern
pat2) = IPattern -> IPattern -> IPattern
ISeqConsPat (IPattern -> IPattern -> IPattern)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> IPattern)
-> EvalM IPattern -> EvalM IPattern
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat2

desugarLoopRange :: LoopRange -> EvalM ILoopRange
desugarLoopRange :: LoopRange
-> StateT EvalState (ExceptT EgisonError RuntimeM) ILoopRange
desugarLoopRange (LoopRange Expr
sExpr Expr
eExpr Pattern
pat) =
  IExpr -> IExpr -> IPattern -> ILoopRange
ILoopRange (IExpr -> IExpr -> IPattern -> ILoopRange)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     (IExpr -> IPattern -> ILoopRange)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
sExpr StateT
  EvalState
  (ExceptT EgisonError RuntimeM)
  (IExpr -> IPattern -> ILoopRange)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IPattern -> ILoopRange)
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
eExpr StateT
  EvalState (ExceptT EgisonError RuntimeM) (IPattern -> ILoopRange)
-> EvalM IPattern
-> StateT EvalState (ExceptT EgisonError RuntimeM) ILoopRange
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern -> EvalM IPattern
desugarPattern' Pattern
pat

desugarBindings :: [BindingExpr] -> EvalM [IBindingExpr]
desugarBindings :: [BindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
desugarBindings = (BindingExpr
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr)
-> [BindingExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM BindingExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr
desugarBinding
  where
    desugarBinding :: BindingExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr
desugarBinding (Bind PrimitiveDataPattern
name Expr
expr) = do
      let name' :: PDPatternBase Var
name' = (String -> Var) -> PrimitiveDataPattern -> PDPatternBase Var
forall a b. (a -> b) -> PDPatternBase a -> PDPatternBase b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Var
stringToVar PrimitiveDataPattern
name
      IExpr
expr' <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
      case (PrimitiveDataPattern
name, IExpr
expr') of
        (PDPatVar String
var, ILambdaExpr Maybe Var
Nothing [Var]
args IExpr
body) ->
          IBindingExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PDPatternBase Var
name', Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> [Index (Maybe Var)] -> Var
Var String
var [])) [Var]
args IExpr
body)
        (PrimitiveDataPattern, IExpr)
_ -> IBindingExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PDPatternBase Var
name', IExpr
expr')
    desugarBinding (BindWithIndices VarWithIndices
vwi Expr
expr) = do
      (Var
var, IExpr
iexpr) <- VarWithIndices -> Expr -> EvalM (Var, IExpr)
desugarDefineWithIndices VarWithIndices
vwi Expr
expr
      IBindingExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar Var
var, IExpr
iexpr)
    -- BindWithType: desugar like DefineWithType
    desugarBinding (BindWithType TypedVarWithIndices
typedVarWI Expr
body) = do
      let name :: String
name = TypedVarWithIndices -> String
typedVarName TypedVarWithIndices
typedVarWI
          params :: [TypedParam]
params = TypedVarWithIndices -> [TypedParam]
typedVarParams TypedVarWithIndices
typedVarWI
          argPatterns :: [Arg ArgPattern]
argPatterns = (TypedParam -> Arg ArgPattern) -> [TypedParam] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map TypedParam -> Arg ArgPattern
typedParamToArgPattern [TypedParam]
params
          lambdaExpr :: Expr
lambdaExpr = if [Arg ArgPattern] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Arg ArgPattern]
argPatterns
                         then Expr
body
                         else [Arg ArgPattern] -> Expr -> Expr
LambdaExpr [Arg ArgPattern]
argPatterns Expr
body
      IExpr
body' <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
lambdaExpr
      let body'' :: IExpr
body'' = case IExpr
body' of
            ILambdaExpr Maybe Var
Nothing [Var]
args IExpr
b -> Maybe Var -> [Var] -> IExpr -> IExpr
ILambdaExpr (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> [Index (Maybe Var)] -> Var
Var String
name [])) [Var]
args IExpr
b
            IExpr
other -> IExpr
other
      IBindingExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> PDPatternBase Var
forall var. var -> PDPatternBase var
PDPatVar (String -> [Index (Maybe Var)] -> Var
Var String
name []), IExpr
body'')

desugarMatchClauses :: [MatchClause] -> EvalM [IMatchClause]
desugarMatchClauses :: [MatchClause] -> EvalM [IMatchClause]
desugarMatchClauses = (MatchClause
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IMatchClause)
-> [MatchClause] -> EvalM [IMatchClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Pattern
pat, Expr
expr) -> (,) (IPattern -> IExpr -> IMatchClause)
-> EvalM IPattern
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IMatchClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> EvalM IPattern
desugarPattern Pattern
pat StateT
  EvalState (ExceptT EgisonError RuntimeM) (IExpr -> IMatchClause)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IMatchClause
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr)

desugarPatternDef :: PatternDef -> EvalM IPatternDef
desugarPatternDef :: PatternDef -> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
desugarPatternDef (PatternDef PrimitivePatPattern
pp Expr
matcher [(PrimitiveDataPattern, Expr)]
pds) =
  (PrimitivePatPattern
pp,,) (IExpr
 -> [IBindingExpr] -> (PrimitivePatPattern, IExpr, [IBindingExpr]))
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([IBindingExpr] -> (PrimitivePatPattern, IExpr, [IBindingExpr]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
matcher StateT
  EvalState
  (ExceptT EgisonError RuntimeM)
  ([IBindingExpr] -> (PrimitivePatPattern, IExpr, [IBindingExpr]))
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
-> EvalM (PrimitivePatPattern, IExpr, [IBindingExpr])
forall a b.
StateT EvalState (ExceptT EgisonError RuntimeM) (a -> b)
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(PrimitiveDataPattern, Expr)]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
desugarPrimitiveDataMatchClauses [(PrimitiveDataPattern, Expr)]
pds

desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, Expr)] -> EvalM [(IPrimitiveDataPattern, IExpr)]
desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, Expr)]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
desugarPrimitiveDataMatchClauses = ((PrimitiveDataPattern, Expr)
 -> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr)
-> [(PrimitiveDataPattern, Expr)]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [IBindingExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(PrimitiveDataPattern
pd, Expr
expr) -> ((String -> Var) -> PrimitiveDataPattern -> PDPatternBase Var
forall a b. (a -> b) -> PDPatternBase a -> PDPatternBase b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Var
stringToVar PrimitiveDataPattern
pd,) (IExpr -> IBindingExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) IBindingExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr)

desugarDefineWithIndices :: VarWithIndices -> Expr -> EvalM (Var, IExpr)
-- Case 1: No indices - simple desugaring without withSymbols/transpose
desugarDefineWithIndices :: VarWithIndices -> Expr -> EvalM (Var, IExpr)
desugarDefineWithIndices (VarWithIndices String
name []) Expr
expr = do
  IExpr
expr' <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
  (Var, IExpr) -> EvalM (Var, IExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [Index (Maybe Var)] -> Var
Var String
name [], IExpr
expr')

-- Case 2: Non-empty indices - wrap with withSymbols and transpose
desugarDefineWithIndices (VarWithIndices String
name [VarIndex]
is) Expr
expr = do
  let ([Bool]
isSubs, [String]
indexNames) = [(Bool, String)] -> ([Bool], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Bool, String)] -> ([Bool], [String]))
-> [(Bool, String)] -> ([Bool], [String])
forall a b. (a -> b) -> a -> b
$ (VarIndex -> [(Bool, String)]) -> [VarIndex] -> [(Bool, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [(Bool, String)]
extractSubSupIndex [VarIndex]
is
  Expr
expr <- if (VarIndex -> Bool) -> [VarIndex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any VarIndex -> Bool
isExtendedIndice [VarIndex]
is
             then [VarIndex] -> [Bool] -> [String] -> Expr -> EvalM Expr
desugarExtendedIndices [VarIndex]
is [Bool]
isSubs [String]
indexNames Expr
expr
             else Expr -> EvalM Expr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
expr
  IExpr
body <- Expr -> StateT EvalState (ExceptT EgisonError RuntimeM) IExpr
desugar Expr
expr
  let indexNamesCollection :: IExpr
indexNamesCollection = [IExpr] -> IExpr
ICollectionExpr ((String -> IExpr) -> [String] -> [IExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> IExpr
IVarExpr [String]
indexNames)
  let is' :: [Index (Maybe a)]
is' = (Bool -> Index (Maybe a)) -> [Bool] -> [Index (Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
b -> if Bool
b then Maybe a -> Index (Maybe a)
forall a. a -> Index a
Sub Maybe a
forall a. Maybe a
Nothing else Maybe a -> Index (Maybe a)
forall a. a -> Index a
Sup Maybe a
forall a. Maybe a
Nothing) [Bool]
isSubs
  -- ITransposeExpr takes (permutation, tensor) as arguments to match tTranspose
  (Var, IExpr) -> EvalM (Var, IExpr)
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [Index (Maybe Var)] -> Var
Var String
name [Index (Maybe Var)]
forall {a}. [Index (Maybe a)]
is', [String] -> IExpr -> IExpr
IWithSymbolsExpr [String]
indexNames (IExpr -> IExpr -> IExpr
ITransposeExpr IExpr
indexNamesCollection IExpr
body))

varWithIndicesToVar :: VarWithIndices -> Var
varWithIndicesToVar :: VarWithIndices -> Var
varWithIndicesToVar (VarWithIndices String
name [VarIndex]
is) = String -> [Index (Maybe Var)] -> Var
Var String
name ((VarIndex -> [Index (Maybe Var)])
-> [VarIndex] -> [Index (Maybe Var)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [Index (Maybe Var)]
transVarIndex [VarIndex]
is)

transVarIndex :: VarIndex -> [Index (Maybe Var)]
transVarIndex :: VarIndex -> [Index (Maybe Var)]
transVarIndex (VSubscript String
x)            = [Maybe Var -> Index (Maybe Var)
forall a. a -> Index a
Sub (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> Var
stringToVar String
x))]
transVarIndex (VSuperscript String
x)          = [Maybe Var -> Index (Maybe Var)
forall a. a -> Index a
Sup (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> Var
stringToVar String
x))]
transVarIndex (VMultiSubscript String
x Integer
s String
e)   = [Maybe Var -> Integer -> Maybe Var -> Index (Maybe Var)
forall a. a -> Integer -> a -> Index a
MultiSub (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> Var
stringToVar String
x)) Integer
s (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> Var
stringToVar String
e))]
transVarIndex (VMultiSuperscript String
x Integer
s String
e) = [Maybe Var -> Integer -> Maybe Var -> Index (Maybe Var)
forall a. a -> Integer -> a -> Index a
MultiSup (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> Var
stringToVar String
x)) Integer
s (Var -> Maybe Var
forall a. a -> Maybe a
Just (String -> Var
stringToVar String
e))]
transVarIndex (VGroupScripts [VarIndex]
xs)        = (VarIndex -> [Index (Maybe Var)])
-> [VarIndex] -> [Index (Maybe Var)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [Index (Maybe Var)]
transVarIndex [VarIndex]
xs
transVarIndex (VSymmScripts [VarIndex]
xs)         = (VarIndex -> [Index (Maybe Var)])
-> [VarIndex] -> [Index (Maybe Var)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [Index (Maybe Var)]
transVarIndex [VarIndex]
xs
transVarIndex (VAntiSymmScripts [VarIndex]
xs)     = (VarIndex -> [Index (Maybe Var)])
-> [VarIndex] -> [Index (Maybe Var)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [Index (Maybe Var)]
transVarIndex [VarIndex]
xs

extractSubSupIndex :: VarIndex -> [(Bool, String)]
extractSubSupIndex :: VarIndex -> [(Bool, String)]
extractSubSupIndex (VSubscript String
x)        = [(Bool
True, String
x)]
extractSubSupIndex (VSuperscript String
x)      = [(Bool
False, String
x)]
extractSubSupIndex (VGroupScripts [VarIndex]
xs)    = (VarIndex -> [(Bool, String)]) -> [VarIndex] -> [(Bool, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [(Bool, String)]
extractSubSupIndex [VarIndex]
xs
extractSubSupIndex (VSymmScripts [VarIndex]
xs)     = (VarIndex -> [(Bool, String)]) -> [VarIndex] -> [(Bool, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [(Bool, String)]
extractSubSupIndex [VarIndex]
xs
extractSubSupIndex (VAntiSymmScripts [VarIndex]
xs) = (VarIndex -> [(Bool, String)]) -> [VarIndex] -> [(Bool, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [(Bool, String)]
extractSubSupIndex [VarIndex]
xs

desugarExtendedIndices :: [VarIndex] -> [Bool] -> [String] -> Expr -> EvalM Expr
desugarExtendedIndices :: [VarIndex] -> [Bool] -> [String] -> Expr -> EvalM Expr
desugarExtendedIndices [VarIndex]
indices [Bool]
isSubs [String]
indexNames Expr
tensorBody = do
  String
tensorName <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
  Expr
tensorGenExpr <- [VarIndex] -> Expr -> [String] -> [BindingExpr] -> EvalM Expr
f [VarIndex]
indices (String -> Expr
VarExpr String
tensorName) [] []
  let indexFunctionExpr :: Expr
indexFunctionExpr = [Arg ArgPattern] -> Expr -> Expr
LambdaExpr [ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (ArgPattern -> Arg ArgPattern) -> ArgPattern -> Arg ArgPattern
forall a b. (a -> b) -> a -> b
$ (Arg ArgPattern -> ArgPattern -> ArgPattern)
-> ArgPattern -> [Arg ArgPattern] -> ArgPattern
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Arg ArgPattern -> ArgPattern -> ArgPattern
APConsPat ArgPattern
APEmptyPat ((VarWithIndices -> Arg ArgPattern)
-> [VarWithIndices] -> [Arg ArgPattern]
forall a b. (a -> b) -> [a] -> [b]
map (ArgPattern -> Arg ArgPattern
forall a. a -> Arg a
Arg (ArgPattern -> Arg ArgPattern)
-> (VarWithIndices -> ArgPattern)
-> VarWithIndices
-> Arg ArgPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarWithIndices -> ArgPattern
APPatVar) ((String -> VarWithIndices) -> [String] -> [VarWithIndices]
forall a b. (a -> b) -> [a] -> [b]
map String -> VarWithIndices
stringToVarWithIndices [String]
indexNames))] Expr
tensorGenExpr
  let genTensorExpr :: Expr
genTensorExpr = Expr -> Expr -> Expr
GenerateTensorExpr Expr
indexFunctionExpr (String -> [Expr] -> Expr
makeApply String
"tensorShape" [String -> Expr
VarExpr String
tensorName])
  let tensorIndices :: [IndexExpr Expr]
tensorIndices = (Bool -> String -> IndexExpr Expr)
-> [Bool] -> [String] -> [IndexExpr Expr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Bool
isSub String
name -> if Bool
isSub then Expr -> IndexExpr Expr
forall a. a -> IndexExpr a
Subscript (String -> Expr
VarExpr String
name) else Expr -> IndexExpr Expr
forall a. a -> IndexExpr a
Superscript (String -> Expr
VarExpr String
name)) [Bool]
isSubs [String]
indexNames
  Expr -> EvalM Expr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> EvalM Expr) -> Expr -> EvalM Expr
forall a b. (a -> b) -> a -> b
$ [BindingExpr] -> Expr -> Expr
LetExpr [PrimitiveDataPattern -> Expr -> BindingExpr
Bind (String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
tensorName) Expr
tensorBody] (Bool -> Expr -> [IndexExpr Expr] -> Expr
IndexedExpr Bool
True Expr
genTensorExpr [IndexExpr Expr]
tensorIndices)
 where
  f :: [VarIndex] -> Expr -> [String] -> [BindingExpr] -> EvalM Expr
  f :: [VarIndex] -> Expr -> [String] -> [BindingExpr] -> EvalM Expr
f [] Expr
expr [] []       = Expr -> EvalM Expr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
expr
  f [] Expr
expr [] [BindingExpr]
bindings = Expr -> EvalM Expr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> EvalM Expr) -> Expr -> EvalM Expr
forall a b. (a -> b) -> a -> b
$ [BindingExpr] -> Expr -> Expr
LetRecExpr [BindingExpr]
bindings Expr
expr
  f [] Expr
expr [String]
signs [BindingExpr]
bindings =
    Expr -> EvalM Expr
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> EvalM Expr) -> Expr -> EvalM Expr
forall a b. (a -> b) -> a -> b
$ [BindingExpr] -> Expr -> Expr
LetRecExpr [BindingExpr]
bindings (String -> [Expr] -> Expr
makeApply String
"product" [[Expr] -> Expr
CollectionExpr ((String -> Expr) -> [String] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
VarExpr [String]
signs [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr
expr])])
  f (VarIndex
index:[VarIndex]
indices) Expr
expr [String]
signs [BindingExpr]
bindings = do
    (Expr
indices', [String]
signs', [BindingExpr]
bindings') <- VarIndex -> EvalM (Expr, [String], [BindingExpr])
genBindings VarIndex
index
    let isSubs :: [Bool]
isSubs = VarIndex -> [Bool]
subOrSupScripts VarIndex
index
    [String]
symbols <- (Bool -> StateT EvalState (ExceptT EgisonError RuntimeM) String)
-> [Bool]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT EvalState (ExceptT EgisonError RuntimeM) String
-> Bool -> StateT EvalState (ExceptT EgisonError RuntimeM) String
forall a b. a -> b -> a
const StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh) [Bool]
isSubs
    let is :: [IndexExpr Expr]
is = (String -> Bool -> IndexExpr Expr)
-> [String] -> [Bool] -> [IndexExpr Expr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
x Bool
isSub -> (if Bool
isSub then Expr -> IndexExpr Expr
forall a. a -> IndexExpr a
Subscript else Expr -> IndexExpr Expr
forall a. a -> IndexExpr a
Superscript) (String -> Expr
VarExpr String
x)) [String]
symbols [Bool]
isSubs
    [VarIndex] -> Expr -> [String] -> [BindingExpr] -> EvalM Expr
f [VarIndex]
indices (Bool -> Expr -> [IndexExpr Expr] -> Expr
IndexedExpr Bool
True Expr
expr [IndexExpr Expr]
is)
      ([String]
signs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
signs') ([BindingExpr]
bindings [BindingExpr] -> [BindingExpr] -> [BindingExpr]
forall a. [a] -> [a] -> [a]
++ [BindingExpr]
bindings' [BindingExpr] -> [BindingExpr] -> [BindingExpr]
forall a. [a] -> [a] -> [a]
++ [PrimitiveDataPattern -> Expr -> BindingExpr
Bind ((String -> PrimitiveDataPattern -> PrimitiveDataPattern)
-> PrimitiveDataPattern -> [String] -> PrimitiveDataPattern
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PrimitiveDataPattern
-> PrimitiveDataPattern -> PrimitiveDataPattern
forall var.
PDPatternBase var -> PDPatternBase var -> PDPatternBase var
PDConsPat (PrimitiveDataPattern
 -> PrimitiveDataPattern -> PrimitiveDataPattern)
-> (String -> PrimitiveDataPattern)
-> String
-> PrimitiveDataPattern
-> PrimitiveDataPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar) PrimitiveDataPattern
forall var. PDPatternBase var
PDEmptyPat [String]
symbols) Expr
indices'])

  subOrSupScripts :: VarIndex -> [Bool]
  subOrSupScripts :: VarIndex -> [Bool]
subOrSupScripts VSubscript{}          = [Bool
True]
  subOrSupScripts VSuperscript{}        = [Bool
False]
  subOrSupScripts (VGroupScripts [VarIndex]
xs)    = (VarIndex -> [Bool]) -> [VarIndex] -> [Bool]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [Bool]
subOrSupScripts [VarIndex]
xs
  subOrSupScripts (VSymmScripts [VarIndex]
xs)     = (VarIndex -> [Bool]) -> [VarIndex] -> [Bool]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [Bool]
subOrSupScripts [VarIndex]
xs
  subOrSupScripts (VAntiSymmScripts [VarIndex]
xs) = (VarIndex -> [Bool]) -> [VarIndex] -> [Bool]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap VarIndex -> [Bool]
subOrSupScripts [VarIndex]
xs

  genBindings :: VarIndex -> EvalM (Expr, [String], [BindingExpr])
  genBindings :: VarIndex -> EvalM (Expr, [String], [BindingExpr])
genBindings (VSubscript String
x)   = (Expr, [String], [BindingExpr])
-> EvalM (Expr, [String], [BindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Expr] -> Expr
CollectionExpr [String -> Expr
VarExpr String
x], [], [])
  genBindings (VSuperscript String
x) = (Expr, [String], [BindingExpr])
-> EvalM (Expr, [String], [BindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Expr] -> Expr
CollectionExpr [String -> Expr
VarExpr String
x], [], [])
  genBindings (VGroupScripts [VarIndex]
xs) = do
    ([Expr]
indices, [[String]]
signss, [[BindingExpr]]
bindingss) <- [(Expr, [String], [BindingExpr])]
-> ([Expr], [[String]], [[BindingExpr]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Expr, [String], [BindingExpr])]
 -> ([Expr], [[String]], [[BindingExpr]]))
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(Expr, [String], [BindingExpr])]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Expr], [[String]], [[BindingExpr]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VarIndex -> EvalM (Expr, [String], [BindingExpr]))
-> [VarIndex]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(Expr, [String], [BindingExpr])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarIndex -> EvalM (Expr, [String], [BindingExpr])
genBindings [VarIndex]
xs
    let newIndices :: Expr
newIndices =
          -- If indices are all CollectionExpr, we can calculate the concatenated result of them
          case [Expr] -> Maybe [Expr]
allCollections [Expr]
indices of
            Just [Expr]
xs -> [Expr] -> Expr
CollectionExpr [Expr]
xs
            Maybe [Expr]
Nothing -> String -> [Expr] -> Expr
makeApply String
"concat" [[Expr] -> Expr
CollectionExpr [Expr]
indices]
    (Expr, [String], [BindingExpr])
-> EvalM (Expr, [String], [BindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr
newIndices, [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
signss, [[BindingExpr]] -> [BindingExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BindingExpr]]
bindingss)
    where
      allCollections :: [Expr] -> Maybe [Expr]
allCollections []                          = [Expr] -> Maybe [Expr]
forall a. a -> Maybe a
Just []
      allCollections (CollectionExpr [Expr]
xs : [Expr]
exprs) = ([Expr]
xs ++) ([Expr] -> [Expr]) -> Maybe [Expr] -> Maybe [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr] -> Maybe [Expr]
allCollections [Expr]
exprs
      allCollections [Expr]
_                           = Maybe [Expr]
forall a. Maybe a
Nothing
  genBindings (VSymmScripts [VarIndex]
xs) = do
    ([Expr]
indices, [[String]]
signss, [[BindingExpr]]
bindingss) <- [(Expr, [String], [BindingExpr])]
-> ([Expr], [[String]], [[BindingExpr]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Expr, [String], [BindingExpr])]
 -> ([Expr], [[String]], [[BindingExpr]]))
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(Expr, [String], [BindingExpr])]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Expr], [[String]], [[BindingExpr]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VarIndex -> EvalM (Expr, [String], [BindingExpr]))
-> [VarIndex]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(Expr, [String], [BindingExpr])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarIndex -> EvalM (Expr, [String], [BindingExpr])
genBindings [VarIndex]
xs
    let signs :: [String]
signs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
signss
    let bindings :: [BindingExpr]
bindings = [[BindingExpr]] -> [BindingExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BindingExpr]]
bindingss
    String
sortedCollectionName <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
    let newBindings :: [BindingExpr]
newBindings = [BindingExpr]
bindings [BindingExpr] -> [BindingExpr] -> [BindingExpr]
forall a. [a] -> [a] -> [a]
++ [PrimitiveDataPattern -> Expr -> BindingExpr
Bind ([PrimitiveDataPattern] -> PrimitiveDataPattern
forall var. [PDPatternBase var] -> PDPatternBase var
PDTuplePat [PrimitiveDataPattern
forall var. PDPatternBase var
PDWildCard, String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
sortedCollectionName]) (String -> [Expr] -> Expr
makeApply String
"sortWithSign" [[Expr] -> Expr
CollectionExpr [Expr]
indices])]
    (Expr, [String], [BindingExpr])
-> EvalM (Expr, [String], [BindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Expr
VarExpr String
sortedCollectionName, [String]
signs, [BindingExpr]
newBindings)
  genBindings (VAntiSymmScripts [VarIndex]
xs) = do
    ([Expr]
indices, [[String]]
signss, [[BindingExpr]]
bindingss) <- [(Expr, [String], [BindingExpr])]
-> ([Expr], [[String]], [[BindingExpr]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Expr, [String], [BindingExpr])]
 -> ([Expr], [[String]], [[BindingExpr]]))
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(Expr, [String], [BindingExpr])]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     ([Expr], [[String]], [[BindingExpr]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VarIndex -> EvalM (Expr, [String], [BindingExpr]))
-> [VarIndex]
-> StateT
     EvalState
     (ExceptT EgisonError RuntimeM)
     [(Expr, [String], [BindingExpr])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarIndex -> EvalM (Expr, [String], [BindingExpr])
genBindings [VarIndex]
xs
    let signs :: [String]
signs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
signss
    let bindings :: [BindingExpr]
bindings = [[BindingExpr]] -> [BindingExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BindingExpr]]
bindingss
    String
sortedCollectionName <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
    String
signName <- StateT EvalState (ExceptT EgisonError RuntimeM) String
forall (m :: * -> *). MonadRuntime m => m String
fresh
    let newBindings :: [BindingExpr]
newBindings = [BindingExpr]
bindings [BindingExpr] -> [BindingExpr] -> [BindingExpr]
forall a. [a] -> [a] -> [a]
++ [PrimitiveDataPattern -> Expr -> BindingExpr
Bind ([PrimitiveDataPattern] -> PrimitiveDataPattern
forall var. [PDPatternBase var] -> PDPatternBase var
PDTuplePat [String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
signName, String -> PrimitiveDataPattern
forall var. var -> PDPatternBase var
PDPatVar String
sortedCollectionName]) (String -> [Expr] -> Expr
makeApply String
"sortWithSign" [[Expr] -> Expr
CollectionExpr [Expr]
indices])]
    (Expr, [String], [BindingExpr])
-> EvalM (Expr, [String], [BindingExpr])
forall a. a -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Expr
VarExpr String
sortedCollectionName, String
signName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
signs, [BindingExpr]
newBindings)

--
-- Utils
--

extractIndexExpr :: IndexExpr a -> a
extractIndexExpr :: forall a. IndexExpr a -> a
extractIndexExpr (Subscript a
x)    = a
x
extractIndexExpr (Superscript a
x)  = a
x
extractIndexExpr (SupSubscript a
x) = a
x
extractIndexExpr (Userscript a
x)   = a
x
extractIndexExpr IndexExpr a
_                = String -> a
forall a. HasCallStack => String -> a
error String
"extractIndexExpr: Not supported"

isExtendedIndice :: VarIndex -> Bool
isExtendedIndice :: VarIndex -> Bool
isExtendedIndice VSubscript{}       = Bool
False
isExtendedIndice VSuperscript{}     = Bool
False
isExtendedIndice (VGroupScripts [VarIndex]
xs) = VarIndex -> Bool
isExtendedIndice ([VarIndex] -> VarIndex
forall a. HasCallStack => [a] -> a
head [VarIndex]
xs)
isExtendedIndice VarIndex
_                  = Bool
True