<commit_before>{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}
{-# OPTIONS -W #-}

module Language.Hakaru.Simplify
  ( closeLoop
  , simplify
  , toMaple
  , Simplifiable
  , SimplifyException(MapleException,InterpreterException)) where

-- Take strings from Maple and interpret them in Haskell (Hakaru)

import Prelude hiding (Real)
import Control.Exception
import Language.Hakaru.Syntax (Measure, Vector, Prob, Real)
import Language.Hakaru.Expect (Expect, unExpect)
import Language.Hakaru.Maple (Maple, runMaple)
import Language.Hakaru.Any (Any)
import Data.Typeable (Typeable, typeOf)
import System.MapleSSH (maple)
import Language.Haskell.Interpreter hiding (typeOf)

import Language.Hakaru.Util.Lex (readMapleString)


data SimplifyException = MapleException String String
                       | InterpreterException String
                       deriving (Show, Typeable)
instance Exception SimplifyException


ourContext :: MonadInterpreter m => m ()
ourContext = do
  let modules = ["Language.Hakaru.RoundTrip"]
  loadModules modules
  setImports modules

closeLoop :: (Typeable a) => String -> IO a
closeLoop s = action where
  action = do
    -- putStrLn ("To Haskell: " ++ s')
    result <- runInterpreter (ourContext >> interpret s' undefined)
    case result of
      Left err -> throw $ InterpreterException $ show err
      Right a -> return a
  s' :: String
  s' = s ++ " :: " ++ show (typeOf (getArg action))

class (Typeable a) => Simplifiable a where
  mapleType :: a{-unused-} -> String

instance Simplifiable () where mapleType _ = "Unit"
instance Simplifiable Int where mapleType _ = "Int"
instance Simplifiable Real where mapleType _ = "Real"
instance Simplifiable Prob where mapleType _ = "Prob"
instance Simplifiable Bool where mapleType _ = "Bool"

instance (Simplifiable a, Simplifiable b) => Simplifiable (a,b) where
  mapleType _ = "Pair(" ++ mapleType (undefined :: a) ++ "," ++
                           mapleType (undefined :: b) ++ ")"

instance Simplifiable a => Simplifiable [a] where
  mapleType _ = "List(" ++ mapleType (undefined :: a) ++ ")"

instance Simplifiable a => Simplifiable (Measure a) where
  mapleType _ = "Measure(" ++ mapleType (undefined :: a) ++ ")"

instance Simplifiable a => Simplifiable (Vector a) where
  mapleType _ = "Vector(" ++ mapleType (undefined :: a) ++ ")"

instance (Simplifiable a, Simplifiable b) => Simplifiable (a -> b) where
  mapleType _ = "Arrow(" ++ mapleType (undefined :: a) ++ "," ++
                            mapleType (undefined :: b) ++ ")"

mkTypeString :: (Simplifiable a) => String -> a -> String
mkTypeString s t = "Typed(" ++ s ++ ", " ++ mapleType t ++ ")"

simplify :: (Simplifiable a) => Expect Maple a -> IO (Any a)
simplify e = do
  let slo = toMaple e
  hakaru <- do
    -- putStrLn ("\nTo Maple: " ++ slo)
    hopeString <- maple ("timelimit(30,Haskell(SLO:-AST(SLO(" ++ slo ++ "))));")
    case readMapleString hopeString of
      Just hakaru -> return hakaru
      Nothing -> throw $ MapleException slo hopeString
  closeLoop ("Any (" ++ hakaru ++ ")")

getArg :: f a -> a
getArg = undefined

toMaple :: (Simplifiable a) => Expect Maple a -> String
toMaple e = mkTypeString (runMaple (unExpect e) 0) (getArg e)<commit_msg>make time limit even smaller, at least for now.<commit_after>{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}
{-# OPTIONS -W #-}

module Language.Hakaru.Simplify
  ( closeLoop
  , simplify
  , toMaple
  , Simplifiable
  , SimplifyException(MapleException,InterpreterException)) where

-- Take strings from Maple and interpret them in Haskell (Hakaru)

import Prelude hiding (Real)
import Control.Exception
import Language.Hakaru.Syntax (Measure, Vector, Prob, Real)
import Language.Hakaru.Expect (Expect, unExpect)
import Language.Hakaru.Maple (Maple, runMaple)
import Language.Hakaru.Any (Any)
import Data.Typeable (Typeable, typeOf)
import System.MapleSSH (maple)
import Language.Haskell.Interpreter hiding (typeOf)

import Language.Hakaru.Util.Lex (readMapleString)


data SimplifyException = MapleException String String
                       | InterpreterException String
                       deriving (Show, Typeable)
instance Exception SimplifyException


ourContext :: MonadInterpreter m => m ()
ourContext = do
  let modules = ["Language.Hakaru.RoundTrip"]
  loadModules modules
  setImports modules

closeLoop :: (Typeable a) => String -> IO a
closeLoop s = action where
  action = do
    -- putStrLn ("To Haskell: " ++ s')
    result <- runInterpreter (ourContext >> interpret s' undefined)
    case result of
      Left err -> throw $ InterpreterException $ show err
      Right a -> return a
  s' :: String
  s' = s ++ " :: " ++ show (typeOf (getArg action))

class (Typeable a) => Simplifiable a where
  mapleType :: a{-unused-} -> String

instance Simplifiable () where mapleType _ = "Unit"
instance Simplifiable Int where mapleType _ = "Int"
instance Simplifiable Real where mapleType _ = "Real"
instance Simplifiable Prob where mapleType _ = "Prob"
instance Simplifiable Bool where mapleType _ = "Bool"

instance (Simplifiable a, Simplifiable b) => Simplifiable (a,b) where
  mapleType _ = "Pair(" ++ mapleType (undefined :: a) ++ "," ++
                           mapleType (undefined :: b) ++ ")"

instance Simplifiable a => Simplifiable [a] where
  mapleType _ = "List(" ++ mapleType (undefined :: a) ++ ")"

instance Simplifiable a => Simplifiable (Measure a) where
  mapleType _ = "Measure(" ++ mapleType (undefined :: a) ++ ")"

instance Simplifiable a => Simplifiable (Vector a) where
  mapleType _ = "Vector(" ++ mapleType (undefined :: a) ++ ")"

instance (Simplifiable a, Simplifiable b) => Simplifiable (a -> b) where
  mapleType _ = "Arrow(" ++ mapleType (undefined :: a) ++ "," ++
                            mapleType (undefined :: b) ++ ")"

mkTypeString :: (Simplifiable a) => String -> a -> String
mkTypeString s t = "Typed(" ++ s ++ ", " ++ mapleType t ++ ")"

simplify :: (Simplifiable a) => Expect Maple a -> IO (Any a)
simplify e = do
  let slo = toMaple e
  hakaru <- do
    -- putStrLn ("\nTo Maple: " ++ slo)
    hopeString <- maple ("timelimit(5,Haskell(SLO:-AST(SLO(" ++ slo ++ "))));")
    case readMapleString hopeString of
      Just hakaru -> return hakaru
      Nothing -> throw $ MapleException slo hopeString
  closeLoop ("Any (" ++ hakaru ++ ")")

getArg :: f a -> a
getArg = undefined

toMaple :: (Simplifiable a) => Expect Maple a -> String
toMaple e = mkTypeString (runMaple (unExpect e) 0) (getArg e)
{'fraction_non_alphanumeric': 0.12520893481233855, 'fraction_numerical': 0.000759762953958365, 'mean_word_length': 3.622191011235955, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 53, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7457226', 'n_tokens_mistral': 2103, 'n_tokens_neox': 2026, 'n_words': 637}