{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Jikka.RestrictedPython.Convert.DefaultMain
-- Description : makes a default IO format based on types. / 型に基づくデフォルトの入出力フォーマットを作成します。
-- Copyright   : (c) Kimiyuki Onaka, 2021
-- License     : Apache License 2.0
-- Maintainer  : kimiyuki95@gmail.com
-- Stability   : experimental
-- Portability : portable
module Jikka.RestrictedPython.Convert.DefaultMain
  ( run,
  )
where

import Control.Arrow
import Jikka.Common.Alpha
import Jikka.Common.Error
import Jikka.Common.IOFormat
import Jikka.RestrictedPython.Format (formatType)
import Jikka.RestrictedPython.Language.Expr
import Jikka.RestrictedPython.Language.Util

lookupSolve :: MonadError Error m => Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
lookupSolve :: Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
lookupSolve = \case
  [] -> String -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwSymbolError String
"solve function is not defined"
  ToplevelAnnAssign VarName'
_ Type
_ Expr'
_ : Program
stmts -> Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
forall (m :: * -> *).
MonadError Error m =>
Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
lookupSolve Program
stmts
  ToplevelFunctionDef VarName'
f [(VarName', Type)]
args Type
ret [Statement]
body : Program
stmts -> case VarName' -> VarName
forall a. WithLoc' a -> a
value' VarName'
f of
    VarName String
"solve" -> (Maybe Loc, [(VarName', Type)], Type, [Statement])
-> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
forall (m :: * -> *) a. Monad m => a -> m a
return (VarName' -> Maybe Loc
forall a. WithLoc' a -> Maybe Loc
loc' VarName'
f, [(VarName', Type)]
args, Type
ret, [Statement]
body)
    VarName
_ -> Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
forall (m :: * -> *).
MonadError Error m =>
Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
lookupSolve Program
stmts
  ToplevelAssert Expr'
_ : Program
stmts -> Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
forall (m :: * -> *).
MonadError Error m =>
Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
lookupSolve Program
stmts

makeInputFormatFromType :: (MonadAlpha m, MonadError Error m) => Type -> m (FormatTree, String)
makeInputFormatFromType :: Type -> m (FormatTree, String)
makeInputFormatFromType = \case
  Type
IntTy -> do
    String
x <- VarName -> String
unVarName (VarName -> String) -> (VarName' -> VarName) -> VarName' -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName' -> VarName
forall a. WithLoc' a -> a
value' (VarName' -> String) -> m VarName' -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VarName'
forall (m :: * -> *). MonadAlpha m => m VarName'
genVarName'
    (FormatTree, String) -> m (FormatTree, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormatExpr -> FormatTree
Exp (String -> FormatExpr
Var String
x), String
x)
  ListTy Type
t -> do
    String
n <- VarName -> String
unVarName (VarName -> String) -> (VarName' -> VarName) -> VarName' -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName' -> VarName
forall a. WithLoc' a -> a
value' (VarName' -> String) -> m VarName' -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VarName'
forall (m :: * -> *). MonadAlpha m => m VarName'
genVarName'
    String
i <- VarName -> String
unVarName (VarName -> String) -> (VarName' -> VarName) -> VarName' -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName' -> VarName
forall a. WithLoc' a -> a
value' (VarName' -> String) -> m VarName' -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VarName'
forall (m :: * -> *). MonadAlpha m => m VarName'
genVarName'
    (FormatTree
body, String
x) <- Type -> m (FormatTree, String)
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
Type -> m (FormatTree, String)
makeInputFormatFromType Type
t
    FormatTree
body <- ((FormatTree -> m FormatTree) -> FormatTree -> m FormatTree
forall (m :: * -> *).
Monad m =>
(FormatTree -> m FormatTree) -> FormatTree -> m FormatTree
`mapFormatTreeM` FormatTree
body) ((FormatTree -> m FormatTree) -> m FormatTree)
-> (FormatTree -> m FormatTree) -> m FormatTree
forall a b. (a -> b) -> a -> b
$ \case
      Exp FormatExpr
e -> FormatTree -> m FormatTree
forall (m :: * -> *) a. Monad m => a -> m a
return (FormatTree -> m FormatTree) -> FormatTree -> m FormatTree
forall a b. (a -> b) -> a -> b
$ FormatExpr -> FormatTree
Exp (FormatExpr -> String -> FormatExpr
At FormatExpr
e String
i)
      FormatTree
format -> FormatTree -> m FormatTree
forall (m :: * -> *) a. Monad m => a -> m a
return FormatTree
format
    (FormatTree, String) -> m (FormatTree, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([FormatTree] -> FormatTree
Seq [FormatExpr -> FormatTree
Exp (String -> FormatExpr
Var String
n), String -> FormatExpr -> FormatTree -> FormatTree
Loop String
i (String -> FormatExpr
Var String
n) FormatTree
body], String
x)
  Type
t -> String -> m (FormatTree, String)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwSemanticError (String -> m (FormatTree, String))
-> String -> m (FormatTree, String)
forall a b. (a -> b) -> a -> b
$ String
"cannot read input of type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
formatType Type
t

makeOutputFormatFromType' :: (MonadAlpha m, MonadError Error m) => Type -> m (FormatTree, String)
makeOutputFormatFromType' :: Type -> m (FormatTree, String)
makeOutputFormatFromType' = \case
  Type
IntTy -> do
    String
x <- VarName -> String
unVarName (VarName -> String) -> (VarName' -> VarName) -> VarName' -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName' -> VarName
forall a. WithLoc' a -> a
value' (VarName' -> String) -> m VarName' -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VarName'
forall (m :: * -> *). MonadAlpha m => m VarName'
genVarName'
    (FormatTree, String) -> m (FormatTree, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormatExpr -> FormatTree
Exp (String -> FormatExpr
Var String
x), String
x)
  ListTy Type
t -> do
    String
i <- VarName -> String
unVarName (VarName -> String) -> (VarName' -> VarName) -> VarName' -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName' -> VarName
forall a. WithLoc' a -> a
value' (VarName' -> String) -> m VarName' -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VarName'
forall (m :: * -> *). MonadAlpha m => m VarName'
genVarName'
    (FormatTree
body, String
x) <- Type -> m (FormatTree, String)
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
Type -> m (FormatTree, String)
makeOutputFormatFromType' Type
t
    FormatTree
body <- ((FormatTree -> m FormatTree) -> FormatTree -> m FormatTree
forall (m :: * -> *).
Monad m =>
(FormatTree -> m FormatTree) -> FormatTree -> m FormatTree
`mapFormatTreeM` FormatTree
body) ((FormatTree -> m FormatTree) -> m FormatTree)
-> (FormatTree -> m FormatTree) -> m FormatTree
forall a b. (a -> b) -> a -> b
$ \case
      Exp FormatExpr
e -> FormatTree -> m FormatTree
forall (m :: * -> *) a. Monad m => a -> m a
return (FormatTree -> m FormatTree) -> FormatTree -> m FormatTree
forall a b. (a -> b) -> a -> b
$ FormatExpr -> FormatTree
Exp (FormatExpr -> String -> FormatExpr
At FormatExpr
e String
i)
      Loop String
i (Len FormatExpr
n) FormatTree
body -> FormatTree -> m FormatTree
forall (m :: * -> *) a. Monad m => a -> m a
return (FormatTree -> m FormatTree) -> FormatTree -> m FormatTree
forall a b. (a -> b) -> a -> b
$ String -> FormatExpr -> FormatTree -> FormatTree
Loop String
i (FormatExpr -> FormatExpr
Len (FormatExpr -> String -> FormatExpr
At FormatExpr
n String
i)) FormatTree
body
      FormatTree
format -> FormatTree -> m FormatTree
forall (m :: * -> *) a. Monad m => a -> m a
return FormatTree
format
    (FormatTree, String) -> m (FormatTree, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([FormatTree] -> FormatTree
Seq [FormatExpr -> FormatTree
Exp (FormatExpr -> FormatExpr
Len (String -> FormatExpr
Var String
x)), String -> FormatExpr -> FormatTree -> FormatTree
Loop String
i (FormatExpr -> FormatExpr
Len (String -> FormatExpr
Var String
x)) FormatTree
body], String
x)
  Type
t -> String -> m (FormatTree, String)
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwSemanticError (String -> m (FormatTree, String))
-> String -> m (FormatTree, String)
forall a b. (a -> b) -> a -> b
$ String
"cannot read input of type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
formatType Type
t

makeOutputFormatFromType :: (MonadAlpha m, MonadError Error m) => Type -> m (FormatTree, Either String [String])
makeOutputFormatFromType :: Type -> m (FormatTree, Either String [String])
makeOutputFormatFromType = \case
  TupleTy [Type]
ts -> do
    [(FormatTree, String)]
outputs <- (Type -> m (FormatTree, String))
-> [Type] -> m [(FormatTree, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> m (FormatTree, String)
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
Type -> m (FormatTree, String)
makeOutputFormatFromType' [Type]
ts
    (FormatTree, Either String [String])
-> m (FormatTree, Either String [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([FormatTree] -> FormatTree
Seq (((FormatTree, String) -> FormatTree)
-> [(FormatTree, String)] -> [FormatTree]
forall a b. (a -> b) -> [a] -> [b]
map (FormatTree, String) -> FormatTree
forall a b. (a, b) -> a
fst [(FormatTree, String)]
outputs), [String] -> Either String [String]
forall a b. b -> Either a b
Right (((FormatTree, String) -> String)
-> [(FormatTree, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FormatTree, String) -> String
forall a b. (a, b) -> b
snd [(FormatTree, String)]
outputs))
  Type
t -> (String -> Either String [String])
-> (FormatTree, String) -> (FormatTree, Either String [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second String -> Either String [String]
forall a b. a -> Either a b
Left ((FormatTree, String) -> (FormatTree, Either String [String]))
-> m (FormatTree, String) -> m (FormatTree, Either String [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m (FormatTree, String)
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
Type -> m (FormatTree, String)
makeOutputFormatFromType' Type
t

makeIOFormatFromType :: (MonadAlpha m, MonadError Error m) => [Type] -> Type -> m IOFormat
makeIOFormatFromType :: [Type] -> Type -> m IOFormat
makeIOFormatFromType [Type]
ts Type
ret = do
  [(FormatTree, String)]
inputs <- (Type -> m (FormatTree, String))
-> [Type] -> m [(FormatTree, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> m (FormatTree, String)
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
Type -> m (FormatTree, String)
makeInputFormatFromType [Type]
ts
  (FormatTree
outputTree, Either String [String]
outputVariables) <- Type -> m (FormatTree, Either String [String])
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
Type -> m (FormatTree, Either String [String])
makeOutputFormatFromType Type
ret
  IOFormat -> m IOFormat
forall (m :: * -> *) a. Monad m => a -> m a
return (IOFormat -> m IOFormat) -> IOFormat -> m IOFormat
forall a b. (a -> b) -> a -> b
$
    IOFormat :: [String]
-> FormatTree -> Either String [String] -> FormatTree -> IOFormat
IOFormat
      { inputTree :: FormatTree
inputTree = [FormatTree] -> FormatTree
Seq (((FormatTree, String) -> FormatTree)
-> [(FormatTree, String)] -> [FormatTree]
forall a b. (a -> b) -> [a] -> [b]
map (FormatTree, String) -> FormatTree
forall a b. (a, b) -> a
fst [(FormatTree, String)]
inputs),
        inputVariables :: [String]
inputVariables = ((FormatTree, String) -> String)
-> [(FormatTree, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FormatTree, String) -> String
forall a b. (a, b) -> b
snd [(FormatTree, String)]
inputs,
        outputVariables :: Either String [String]
outputVariables = Either String [String]
outputVariables,
        outputTree :: FormatTree
outputTree = FormatTree
outputTree
      }

run :: (MonadAlpha m, MonadError Error m) => Program -> m IOFormat
run :: Program -> m IOFormat
run Program
prog = String -> m IOFormat -> m IOFormat
forall (m :: * -> *) a. MonadError Error m => String -> m a -> m a
wrapError' String
"Jikka.RestrictedPython.Convert.DefaultMain" (m IOFormat -> m IOFormat) -> m IOFormat -> m IOFormat
forall a b. (a -> b) -> a -> b
$ do
  (Maybe Loc
_, [(VarName', Type)]
args, Type
ret, [Statement]
_) <- Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
forall (m :: * -> *).
MonadError Error m =>
Program -> m (Maybe Loc, [(VarName', Type)], Type, [Statement])
lookupSolve Program
prog
  [Type] -> Type -> m IOFormat
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
[Type] -> Type -> m IOFormat
makeIOFormatFromType (((VarName', Type) -> Type) -> [(VarName', Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (VarName', Type) -> Type
forall a b. (a, b) -> b
snd [(VarName', Type)]
args) Type
ret