From 6d4948f4b40ab63990b09a3fa1f62b3618710c1b Mon Sep 17 00:00:00 2001 From: Nikolaos Bezirgiannis Date: Thu, 11 Jan 2024 16:44:09 +0100 Subject: [PATCH] Fix smartness --- .../executables/plutus/AnyProgram/Apply.hs | 6 +- .../executables/plutus/AnyProgram/IO.hs | 10 +- plutus-core/executables/plutus/Common.hs | 6 +- plutus-core/executables/plutus/GetOpt.hs | 123 ++++++++++-------- .../executables/plutus/Mode/Compile.hs | 7 +- .../executables/plutus/Mode/HelpVersion.hs | 13 +- plutus-core/executables/plutus/Types.hs | 3 +- plutus-core/plutus-core.cabal | 1 + 8 files changed, 103 insertions(+), 66 deletions(-) diff --git a/plutus-core/executables/plutus/AnyProgram/Apply.hs b/plutus-core/executables/plutus/AnyProgram/Apply.hs index 782644e8bca..1916a637ccf 100644 --- a/plutus-core/executables/plutus/AnyProgram/Apply.hs +++ b/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 diff --git a/plutus-core/executables/plutus/AnyProgram/IO.hs b/plutus-core/executables/plutus/AnyProgram/IO.hs index f6d7dc7fe02..3497babf45d 100644 --- a/plutus-core/executables/plutus/AnyProgram/IO.hs +++ b/plutus-core/executables/plutus/AnyProgram/IO.hs @@ -21,7 +21,6 @@ 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 @@ -29,14 +28,15 @@ readProgram sngS fileS = do 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 diff --git a/plutus-core/executables/plutus/Common.hs b/plutus-core/executables/plutus/Common.hs index c379292d342..119cb1f1829 100644 --- a/plutus-core/executables/plutus/Common.hs +++ b/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 diff --git a/plutus-core/executables/plutus/GetOpt.hs b/plutus-core/executables/plutus/GetOpt.hs index 5bae1af24bc..5ba4fe76308 100644 --- a/plutus-core/executables/plutus/GetOpt.hs +++ b/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,6 +20,7 @@ import Control.Monad import System.Console.GetOpt as GetOpt import Control.Lens import Data.Monoid +import System.FilePath data Opts = Opts { _inputs :: [SomeFile] @@ -26,11 +28,13 @@ data Opts = Opts , _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,14 +48,16 @@ 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 @@ -59,11 +65,12 @@ defOpts = Opts , _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 diff --git a/plutus-core/executables/plutus/Mode/Compile.hs b/plutus-core/executables/plutus/Mode/Compile.hs index b04aa01821a..f754e003b98 100644 --- a/plutus-core/executables/plutus/Mode/Compile.hs +++ b/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 diff --git a/plutus-core/executables/plutus/Mode/HelpVersion.hs b/plutus-core/executables/plutus/Mode/HelpVersion.hs index 23285cc9798..3677eaae47d 100644 --- a/plutus-core/executables/plutus/Mode/HelpVersion.hs +++ b/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" diff --git a/plutus-core/executables/plutus/Types.hs b/plutus-core/executables/plutus/Types.hs index a7b2df50de6..c4447d0fe9c 100644 --- a/plutus-core/executables/plutus/Types.hs +++ b/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 diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 637bfbefe54..3d4c2140ffa 100644 --- a/plutus-core/plutus-core.cabal +++ b/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)