Fix smartness

plutus-core/executables/plutus/AnyProgram/Apply.hs

@@ -1,9 +1,12 @@
+{-# LANGUAGE ImplicitParams #-}
 module AnyProgram.Apply
     ( applyProgram
     ) where
 
 import Types
+import GetOpt
 import AnyProgram.With
+
 import PlutusCore qualified as PLC
 import PlutusIR qualified as PIR
 import UntypedPlutusCore qualified as UPLC
@@ -13,8 +16,9 @@ import Control.Monad.Except
 
 -- | Given a singleton witness and two programs of that type witness, apply them together.
 --
-applyProgram :: (MonadError PLC.ApplyProgramError m)
+applyProgram :: (?opts :: Opts, MonadError PLC.ApplyProgramError m)
              => SLang s -> FromLang s -> FromLang s -> m (FromLang s)
+applyProgram _ _ _ | _wholeOpt ?opts = error "error FIXME: not implemented yet"
 applyProgram sng p1 p2 = withSemigroupA (_sann sng) $
     case sng of
         SPir{} -> PIR.applyProgram p1 p2

plutus-core/executables/plutus/AnyProgram/IO.hs

@@ -21,22 +21,22 @@ import PlutusCore.Pretty qualified as PP
 import Prettyprinter
 import Prettyprinter.Render.Text
 import Control.Monad
-import Control.Lens
 
 readProgram :: SLang s -> File s -> IO (FromLang s)
 readProgram sngS fileS = do
     bs <- readFileName (fileS^.fName)
     case fileS^.fType.fFormat of
         Flat_ -> withFlatL sngS $ pure $ unsafeFromRight $ unflat bs
         Text -> parseProgram sngS $ T.decodeUtf8Lenient bs
+        _ -> failE "not implemented yet"
 
 writeProgram :: (?opts :: Opts)
              => SLang s -> File s -> FromLang s -> IO ()
 writeProgram sng file ast
-    | _fNoCode ?opts = pure ()
+    | _noCode ?opts = pure ()
     | otherwise = do
-          when (_verbosity ?opts & has _VFull) $
-              printE $ "Outputting" <+> pretty file
+          when (_verbosity ?opts == VFull) $
+              printE $ show $ "Outputting" <+> pretty file
           case file^.fType.fFormat of
               Flat_ -> writeFileName (file^.fName) $ withFlatL sng $ flat ast
               Text  -> writeFileName (file^.fName)
@@ -45,6 +45,7 @@ writeProgram sng file ast
                     $ layoutPretty defaultLayoutOptions
                     $ withPrettyPlcL sng
                     $ prettyWithStyle (_prettyStyle ?opts) ast
+              _ -> failE "not implemented yet"
 
 prettyWithStyle :: PP.PrettyPlc (FromLang s)
                 => PrettyStyle -> FromLang s -> Doc ann
@@ -53,6 +54,7 @@ prettyWithStyle = \case
         ClassicDebug  -> PP.prettyPlcClassicDebug
         Readable      -> PP.prettyPlcReadableDef
         ReadableDebug -> PP.prettyPlcReadableDebug
+        None -> error "not implemented yet"
 
 readFileName :: FileName -> IO BS.ByteString
 readFileName = \case

plutus-core/executables/plutus/Common.hs

@@ -6,11 +6,11 @@ module Common
 import System.IO
 import System.Exit
 
-printE :: Show a => a -> IO ()
-printE = hPutStrLn stderr . show
+printE :: String -> IO ()
+printE = hPutStrLn stderr
 
 -- like fail , just no wrap it with the text "user error"
-failE :: Show a => a -> IO b
+failE :: String -> IO b
 failE a = do
     printE a
     exitFailure

plutus-core/executables/plutus/GetOpt.hs

@@ -1,11 +1,12 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module GetOpt
     ( Opts (..)
-    , inputs, output, mode, budget, prettyStyle, fNoCode, optimiseLvl, verbosity, lastFileType
+    , inputs, output, mode, budget, prettyStyle, noCode, optimiseLvl, verbosity, lastFileType
     , parseArgs
     , optDescrs
     , GetOpt.usageInfo
@@ -19,18 +20,21 @@ import Control.Monad
 import System.Console.GetOpt as GetOpt
 import Control.Lens
 import Data.Monoid
+import System.FilePath
 
 data Opts = Opts
     { _inputs :: [SomeFile]
     , _output :: Maybe SomeFile
     , _mode :: Mode
     , _budget :: Maybe Budget -- ^ Nothing means unlimited budget
     , _prettyStyle :: PrettyStyle
-    , _fNoCode :: Bool
+    , _noCode :: Bool
+    , _wholeOpt :: Bool
     , _optimiseLvl :: OptimiseLvl
     , _verbosity :: Verbosity
-    , _lastFileType :: FileType
+    , _lastFileType :: Maybe FileType -- ^ Nothing means: use smart-suffix
     }
+    deriving stock Show
 makeLenses ''Opts
 
 parseArgs :: [String] -> IO Opts
@@ -44,26 +48,29 @@ parseArgs args = do
     -- so that it can be used as positioned input in an apply chain of programs
 
     -- fold the options
-    let finalOpts = foldMap (Dual . Endo) getOptRes `appDual` defOpts
+    let -- Dual Endo so as to apply the options in the expected left to right CLI order
+        appDual = appEndo . getDual
+        finalOpts = foldMap (Dual . Endo) getOptRes `appDual` defOpts
                     -- reverse the parsed inputs to match the order of appearance in command-line
                     & inputs %~ reverse
 
-    pure $ finalOpts
+    when (_verbosity finalOpts == VFull) $
+        printE $ "Parsed opts: " ++ show finalOpts
 
-defFileType :: FileType
-defFileType = uplc
+    pure $ finalOpts
 
 defOpts :: Opts
 defOpts = Opts
            { _inputs = empty
            , _output = empty
            , _mode = Compile
            , _prettyStyle = Classic
-           , _fNoCode = False
+           , _noCode = False
+           , _wholeOpt = False
            , _optimiseLvl = SafeOptimise
            , _budget = empty
            , _verbosity = VDefault
-           , _lastFileType = defFileType
+           , _lastFileType = Nothing -- start in smart-mode
            }
 
 defBenchSecs :: Secs
@@ -72,6 +79,10 @@ defBenchSecs = 10
 defDebugFilePath :: FilePath
 defDebugFilePath = "."
 
+-- | When smartness fails, assume that the user supplied this filetype (suffix)
+defFileType :: FileType
+defFileType = read "uplc"
+
 -- Each successful parsing of an option returns a state-transition function
 type OptsFun = Opts -> Opts
 
@@ -88,13 +99,13 @@ optDescrs =
      (ReqArg (setOutput . AbsolutePath) "FILE") "Set output file"
    -- INPUT/OUTPUT types
  , Option ['x'] []
-     (ReqArg (set lastFileType . read) "EXTENSION") "Change extension"
+     -- taken from GHC's -x
+     (ReqArg (set lastFileType . Just . read) "SUFFIX") "Causes all files following this option on the command line to be processed as if they had the suffix SUFFIX"
    -- FIXME: naming,ann partial for data
  , Option ['n'] []
-     (ReqArg (set (lastFileType . fLang . naming) . read) "NAMING") "Change naming"
+     (ReqArg (overFileTypeDefault (fLang . naming) read) "NAMING") "Change naming"
  , Option ['a'] []
-     (ReqArg (set (lastFileType . fLang . ann) . read) "ANNOTATION") "Change annotation"
-
+     (ReqArg (overFileTypeDefault (fLang . ann) read) "ANNOTATION") "Change annotation"
    -- MODES
  , Option [] ["run"]
      (NoArg (set mode Run)) "Execute program after compilation"
@@ -113,38 +124,66 @@ optDescrs =
 
  -- VERBOSITY
  , Option ['q'] ["quiet"]
-     (NoArg (set verbosity VNone)) "Don't print much"
+     (NoArg (set verbosity VNone)) "Don't print text (error) output; rely only on exit codes"
  , Option ['v'] ["verbose"]
-     (NoArg (set verbosity VFull)) "Print a lot"
+     (NoArg (set verbosity VFull)) "Print more than than the default"
 
  -- OTHER
+ -- MAYBE: make -O option also positional/stateful, like the -x/-a/-n.
  , Option ['O'] []
      (ReqArg (set optimiseLvl . read) "INT") "Set optimization level"
+ , Option [] ["whole-opt"]
+     (NoArg (set wholeOpt True)) "Run an extra optimization pass for the final applied program"
  , Option [] ["budget"]
      (ReqArg (set budget . Just . read) "INT,INT") "CPU,MEM budget limit for run, bench, and debug mode"
  , Option [] ["pretty"]
      (ReqArg (set prettyStyle . read) "STYLE") "Set pretty style"
- , Option [] ["fno-code"]
-     (NoArg (set fNoCode True)) "Only typecheck, don't produce code"
+ , Option [] ["no-code"]
+     (NoArg (set noCode True)) "Only typecheck, don't produce code"
  ]
 
 -- Helpers to construct state functions
 ---------------------------------------
 
+setOutput :: FileName -> OptsFun
+setOutput fn s = set output (Just $ mkSomeFile (getFileType s fn) fn) s
+
 addInput :: FileName -> OptsFun
-addInput fn s = over inputs (mkSomeFile (s^.lastFileType) fn :) s
+addInput fn s =
+    over inputs (mkSomeFile (getFileType s fn) fn :) s
 
 -- | naive way to delete some inputs files, used only for fixing StdIn re-setting
 delInputs :: FileName -> OptsFun
 delInputs fn = over inputs (filter (\ (SomeFile _ f) -> f^.fName /= fn))
 
-setOutput :: FileName -> OptsFun
-setOutput fn s = set output (Just $ mkSomeFile (s^.lastFileType) fn) s
+--  1) tries the last filetype specified with -x or
+--  2) detects the filetype from the filename's suffix (if -x was not specified) or
+--  3) Falls back to `defFileType` if all fails.
+getFileType :: Opts -> FileName -> FileType
+getFileType = \case
+    -- -x was specified, so it takes precedence, so don't try to be smart
+    (_lastFileType -> Just x) -> const x
+    _ -> \case
+        -- there is some suffix, try to "smart" interpret it
+        AbsolutePath (takeExtensions -> ('.':suffix)) -> read suffix
+        -- smart failed, use the default filetype
+        _ -> defFileType
 
 -- For options that are not prefixed with dash(es), e.g. plain file/dirs
 fromNonDash :: FilePath -> OptsFun
 fromNonDash = addInput . AbsolutePath
 
+-- | Modify part of the last filetype
+-- Use defFileType if last filetype is unset.
+overFileTypeDefault :: ASetter' FileType arg
+                    -> (String -> arg)
+                    -> String
+                    -> OptsFun
+overFileTypeDefault setter f arg = over lastFileType $ \ mFt ->
+    set (mapped . setter)
+    (f arg)
+    (mFt <|> Just defFileType)
+
 -- READING
 --------------------------------------------------
 
@@ -169,39 +208,21 @@ instance Read OptimiseLvl where
     _ -> error "cannot read optimise level"
 
 instance Read FileType where
+ -- OPTIMIZE: can be defined better using recursion
  readsPrec _prec = one . \case
-    "uplc" -> uplc
-    "plc" -> plc
-    "pir" -> pir
-    "uplc.flat" -> uplcFlat
-    "plc.flat" -> plcFlat
-    "pir.flat" -> pirFlat
-    "data" -> dataFlat
-    "uplc.cbor" -> uplcCbor
-    "plc.cbor" -> plcCbor
-    "flat" -> uplcFlat
-    "cbor" -> uplcCbor
+    "uplc" -> FileType Text $ Uplc Name Unit
+    "plc" -> FileType Text $ Plc Name Unit
+    "pir" -> FileType Text $ Pir Name Unit
+    "uplc.flat" -> FileType Flat_ $ Uplc Name Unit
+    "plc.flat" -> FileType Flat_ $ Plc Name Unit
+    "pir.flat" -> FileType Flat_ $ Pir Name Unit
+    "data" -> FileType Flat_ Data
+    "uplc.cbor" -> FileType Cbor $ Uplc DeBruijn Unit
+    "plc.cbor" -> FileType Cbor $ Plc DeBruijn Unit
+    "flat" -> read "uplc.flat"
+    "cbor" -> read "uplc.cbor"
     _ -> error "cannot read filetype"
-
--- "smart" extensions
--- MAYBE: I could also make them patterns
-uplc, plc, pir, uplcFlat, plcFlat, pirFlat, dataFlat, uplcCbor, plcCbor :: FileType
-uplc = FileType Text $ Uplc Name Unit
-plc = FileType Text $ Plc Name Unit
-pir = FileType Text $ Pir Name Unit
-uplcFlat = FileType Flat_ $ Uplc Name Unit
-plcFlat = FileType Flat_ $ Plc Name Unit
-pirFlat = FileType Flat_ $ Pir Name Unit
-dataFlat = FileType Flat_ Data
-uplcCbor = FileType Cbor $ Uplc DeBruijn Unit
-plcCbor = FileType Cbor $ Plc DeBruijn Unit
--- pirCbor = FileType Cbor $ Pir DeBruijn Unit -- not available
-
--- more helpers
+    -- pirCbor = FileType Cbor $ Pir DeBruijn Unit -- not available
 
 one :: a -> [(a,String)]
 one x = [(x,"")]
-
--- Dual Endo so as to apply the options in the expected left to right CLI order
-appDual :: Dual (Endo a) -> a -> a
-appDual = appEndo . getDual

plutus-core/executables/plutus/Mode/Compile.hs

@@ -15,7 +15,6 @@ import Data.Foldable
 
 import PlutusPrelude
 import Control.Monad
-import Control.Lens
 import Prettyprinter
 
 runCompile :: (?opts :: Opts)
@@ -38,10 +37,10 @@ readCompileApply sngT accT someFileS =
 readCompile :: (?opts :: Opts)
             => SomeFile -> SLang t -> IO (FromLang t)
 readCompile (SomeFile sngS fileS) sngT = do
-    when (_verbosity ?opts & has _VFull) $
-           printE $ "Compiling" <+> pretty fileS
+    when (_verbosity ?opts == VFull) $
+           printE $ show $  "Compiling" <+> pretty fileS
     ast <- readProgram sngS fileS
     case compileProgram sngS sngT ast of
-        Left e -> withOrdPrettyA (_sann sngS) $ failE e
+        Left e -> withOrdPrettyA (_sann sngS) $ failE $ show e
         Right r -> pure r
 

plutus-core/executables/plutus/Mode/HelpVersion.hs

@@ -6,7 +6,18 @@ module Mode.HelpVersion
 import GetOpt
 
 runHelp :: IO ()
-runHelp = putStr $ GetOpt.usageInfo "" GetOpt.optDescrs
+runHelp = do
+    putStr $ GetOpt.usageInfo usageHeader GetOpt.optDescrs
+    putStr usageFooter
+
+usageHeader :: String
+usageHeader =
+    "USAGE: plutus [FILES...] [-o FILE | --stdout] [--pretty|--run|--bench|--debug]"
+
+usageFooter :: String
+usageFooter =
+    "EXAMPLES: FIXME \n"
+
 
 runVersion :: IO ()
 runVersion = putStrLn "Version 0"

plutus-core/executables/plutus/Types.hs

@@ -99,8 +99,7 @@ data PrettyStyle = None
 data Verbosity = VNone
                | VDefault
                | VFull
-               deriving stock (Show)
-makePrisms ''Verbosity
+               deriving stock (Eq, Show)
 
 -- SINGLETONS-related
 

plutus-core/plutus-core.cabal

@@ -686,6 +686,7 @@ executable plutus
     , mtl
     , singletons
     , singletons-th
+    , filepath
 
   default-extensions:
     -- heavy use of GADTs and depedendent matches (which require the GADTs-implied MonoLocalBinds)