eo-phi-normalizer-0.2.0: app/Main.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}

module Main where

import Control.Monad (unless, when)
import Data.Foldable (forM_)

import Data.List (nub)
import Language.EO.Phi (Object (Formation), Program (Program), defaultMain, parseProgram, printTree)
import Language.EO.Phi.Rules.Common (Context (..), applyRules, applyRulesChain)
import Language.EO.Phi.Rules.Yaml (RuleSet (rules, title), convertRule, parseRuleSetFromFile)
import Options.Generic
import System.IO (IOMode (WriteMode), hClose, hPutStr, hPutStrLn, openFile, stdout)

data CLINamedParams = CLINamedParams
  { chain :: Bool
  , rulesYaml :: Maybe String
  , outPath :: Maybe String
  , single :: Bool
  }
  deriving (Generic, Show, ParseRecord, Read, ParseField)

instance ParseFields CLINamedParams where
  parseFields _ _ _ _ =
    CLINamedParams
      <$> parseFields (Just "Print out steps of reduction") (Just "chain") (Just 'c') Nothing
      <*> parseFields (Just "Path to the Yaml file with custom rules") (Just "rules-yaml") Nothing Nothing
      <*> parseFields (Just "Output file path (defaults to stdout)") (Just "output") (Just 'o') Nothing
      <*> parseFields (Just "Print a single normlized expression") (Just "single") (Just 's') Nothing

data CLIOptions = CLIOptions CLINamedParams (Maybe FilePath)
  deriving (Generic, Show, ParseRecord)

main :: IO ()
main = do
  opts <- getRecord "Normalizer"
  let (CLIOptions params inPath) = opts
  let (CLINamedParams{..}) = params
  case rulesYaml of
    Just path -> do
      handle <- maybe (pure stdout) (`openFile` WriteMode) outPath
      let logStr = hPutStr handle
      let logStrLn = hPutStrLn handle
      ruleSet <- parseRuleSetFromFile path
      unless single $ logStrLn ruleSet.title
      src <- maybe getContents readFile inPath
      let progOrError = parseProgram src
      case progOrError of
        Left err -> error ("An error occurred parsing the input program: " <> err)
        Right input@(Program bindings) -> do
          let results
                | chain = applyRulesChain (Context (convertRule <$> ruleSet.rules) [Formation bindings]) (Formation bindings)
                | otherwise = pure <$> applyRules (Context (convertRule <$> ruleSet.rules) [Formation bindings]) (Formation bindings)
              uniqueResults = nub results
              totalResults = length uniqueResults
          when (totalResults == 0) $ error "Could not normalize the program"
          if single
            then logStrLn (printTree (head uniqueResults))
            else do
              logStrLn "Input:"
              logStrLn (printTree input)
              logStrLn "===================================================="
              forM_ (zip [1 ..] uniqueResults) $ \(i, steps) -> do
                logStrLn $
                  "Result " <> show i <> " out of " <> show totalResults <> ":"
                let n = length steps
                forM_ (zip [1 ..] steps) $ \(k, step) -> do
                  when chain $
                    logStr ("[ " <> show k <> " / " <> show n <> " ]")
                  logStrLn (printTree step)
                logStrLn "----------------------------------------------------"
      hClose handle
    -- TODO #48:15m still need to consider `chain` (should rewrite/change defaultMain to mainWithOptions)
    Nothing -> defaultMain