hakaru-0.7.0: commands/HkMaple.hs

{-# LANGUAGE CPP
           , OverloadedStrings
           , DataKinds
           , GADTs
           , RecordWildCards
           , ScopedTypeVariables
           #-}

module Main where

import           Language.Hakaru.Pretty.Concrete as C
import           Language.Hakaru.Pretty.SExpression as S
import           Language.Hakaru.Pretty.Haskell as H
import           Language.Hakaru.Syntax.AST.Transforms
import           Language.Hakaru.Syntax.TypeCheck
import           Language.Hakaru.Command (parseAndInfer', readFromFile')

import           Language.Hakaru.Syntax.Rename
import           Language.Hakaru.Maple

import           Language.Hakaru.Syntax.Transform (Transform(..)
                                                  ,someTransformations)
import           Language.Hakaru.Syntax.IClasses (Some2(..))

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative   (Applicative(..), (<$>))
#endif

import           Data.Monoid ((<>), Monoid(..))
import qualified Data.Text as Text
import qualified Data.Text.Utf8 as IO
import           System.IO (stderr)
import           Data.List (intercalate)
import           Text.Read (readMaybe)
import           Control.Exception(throw)
import qualified Options.Applicative as O
import qualified Data.Map as M


data Options a
  = Options
    { moptions      :: MapleOptions (Maybe String)
    , no_unicode    :: Bool
    , toExpand      :: Maybe [Some2 Transform]
    , printer       :: String
    , program       :: a }
  | ListCommands
  | PrintVersion


parseKeyVal :: O.ReadM (String, String)
parseKeyVal =
  O.maybeReader $ (\str ->
    case map Text.strip $ Text.splitOn "," str of
      [k,v] -> return (Text.unpack k, Text.unpack v)
      _     -> Nothing) . Text.pack

options :: O.Parser (Options FilePath)
options = (Options
  <$> (MapleOptions <$>
        O.option (O.maybeReader (Just . Just))
        ( O.long "command" <>
          O.help ("Command to send to Maple. You may enter a prefix of the command string if "
                 ++"it uniquely identifies a command. ") <>
          O.short 'c' <>
          O.value Nothing )
    <*> O.switch
        ( O.long "debug" <>
          O.help "Prints output that is sent to Maple." )
    <*> O.option O.auto
        ( O.long "timelimit" <>
          O.help "Set Maple to timeout in N seconds." <>
          O.showDefault <>
          O.value 90 <>
          O.metavar "N")
    <*> (M.fromList <$>
          O.many (O.option parseKeyVal
        ( O.long "maple-opt" <>
          O.short 'm' <>
          O.help ( "Extra options to send to Maple\neach options is of the form KEY=VAL\n"
                 ++"where KEY is a Maple name, and VAL is a Maple expression.")
        )))
    <*> pure mempty)
  <*> O.switch
      ( O.long "no-unicode" <>
        O.short 'u' <>
        O.help "Removes unicode characters from names in the Maple output.")
  <*> O.option (O.maybeReader $ fmap (fmap Just) readMaybe)
      ( O.short 'e' <>
        O.long "to-expand" <>
        O.value Nothing <>
        O.help "Transformations to be expanded; default is all transformations" )
  <*> O.strOption
      ( O.short 'p' <>
        O.long "printer" <>
        O.value "concrete" )
  <*> O.strArgument
      ( O.metavar "PROGRAM" <>
        O.help "Filename containing program to be simplified, or \"-\" to read from input." )) O.<|>
  ( O.flag' ListCommands
      ( O.long "list-commands" <>
        O.help "Get list of available commands from Maple." <>
        O.short 'l') ) O.<|>
  ( O.flag' PrintVersion
      ( O.long "version" <>
        O.help "Prints the version of the Hakaru Maple library." <>
        O.short 'v') )

parseOpts :: IO (Options FilePath)
parseOpts = O.execParser $ O.info (O.helper <*> options)
      (O.fullDesc <> O.progDesc progDesc)

progDesc :: String
progDesc = unwords
  ["hk-maple: invokes a Maple command on a Hakaru program. "
  ,"Given a Hakaru program in concrete syntax and a Maple-Hakaru command,"
  ,"typecheck the program"
  ,"invoke the Maple command on the program and its type"
  ,"pretty print, parse and typecheck the program resulting from Maple"
  ]

main :: IO ()
main = parseOpts >>= runMaple

runMaple :: Options FilePath -> IO ()
runMaple ListCommands =
  listCommands >>= \cs -> putStrLn $ "Available Hakaru Maple commands:\n\t"++ intercalate ", " cs

runMaple PrintVersion = printVersion

runMaple Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->
  case prog of
    Left  err  -> IO.hPutStrLn stderr err
    Right ast  -> do
      let et = onTypedASTM $ expandTransformationsWith $
                (maybe id someTransformations toExpand)
                (allTransformationsWithMOpts moptions{command=()})
      TypedAST typ ast' <-
        (case command moptions of
           Just c  -> sendToMaple' moptions{command=c}
           Nothing -> return) =<< et ast
      IO.print
            $ (case printer of
                 "concrete" -> C.pretty
                 "sexpression" -> S.pretty
                 "haskell" -> H.prettyString typ
                 _ -> error "Invalid printer requested")
            $ (if no_unicode then renameAST removeUnicodeChars else id)
            $ ast'

listCommands :: IO [String]
listCommands = do
    let toMaple_ = "use Hakaru, NewSLO in lprint(map(curry(sprintf,`%s`),NewSLO:-Commands)) end use;"
    fromMaple <- maple toMaple_
    maybe (throw $ MapleInterpreterException fromMaple toMaple_)
          return
          (readMaybe fromMaple)

printVersion :: IO ()
printVersion =
  maple "use Hakaru, NewSLO in NewSLO:-PrintVersion() end use;" >>= putStr