Skip to content

Commit a55d968

Browse files
chrisdonechrisdone
authored
Add optparse-applicative support (#78)
1 parent 918bb54 commit a55d968

File tree

2 files changed

+98
-6
lines changed

2 files changed

+98
-6
lines changed

‎examples/31-optparse.hell‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
-- Includes example of Semigroup.
2+
data Opts = Opts {
3+
quiet :: Bool,
4+
filePath :: Text
5+
}
6+
options =
7+
(\quiet path -> Main.Opts { quiet = quiet, filePath = path })
8+
<$> Options.switch (Flag.long "quiet" <> Flag.help "Be quiet?")
9+
<*> Options.strOption (Option.long "path" <> Option.help "The filepath to export")
10+
main = do
11+
opts <- Options.execParser (Options.info (Main.options <**> Options.helper) Options.fullDesc)
12+
Text.putStrLn $ Record.get @"filePath" opts
13+
Text.putStrLn $ Show.show @Bool $ Record.get @"quiet" opts

‎src/Hell.hs‎

Lines changed: 85 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -92,6 +92,7 @@ import Language.Haskell.TH.Instances ()
9292
import qualified Language.Haskell.TH.Syntax as TH
9393
import Lucid hiding (Term, for_, term)
9494
import qualified Options.Applicative as Options
95+
import Options.Applicative (Parser)
9596
import qualified System.Directory as Dir
9697
import System.Environment
9798
import qualified System.Exit as Exit
@@ -469,6 +470,8 @@ data Forall where
469470
StreamTypeOf :: (forall (a :: StreamType). TypeRep a -> Forall) -> Forall
470471
ListOf :: (forall (a :: List). TypeRep a -> Forall) -> Forall
471472
OrdEqShow :: (forall (a :: Type). (Ord a, Eq a, Show a) => TypeRep a -> Forall) -> Forall
473+
Monoidal :: (forall m. (Monoid m) => TypeRep m -> Forall) -> Forall
474+
Applicable :: (forall (m :: Type -> Type). (Applicative m) => TypeRep m -> Forall) -> Forall
472475
Monadic :: (forall (m :: Type -> Type). (Monad m) => TypeRep m -> Forall) -> Forall
473476
GetOf ::
474477
TypeRep (k :: Symbol) ->
@@ -600,7 +603,7 @@ tc (UForall _ _ _ fall _ _ reps0) _env = go reps0 fall
600603
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @Text) -> go reps (f rep)
601604
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @ByteString) -> go reps (f rep)
602605
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @ExitCode) -> go reps (f rep)
603-
| otherwise -> error $ "type doesn't have enough instances " ++ show rep
606+
| otherwise -> error $ "[OrdEqShow] type doesn't have enough instances " ++ show rep
604607
go (SomeTypeRep rep : reps) (Monadic f) =
605608
if
606609
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @IO) -> go reps (f rep)
@@ -610,7 +613,31 @@ tc (UForall _ _ _ fall _ _ reps0) _env = go reps0 fall
610613
| Type.App either' _ <- rep,
611614
Just Type.HRefl <- Type.eqTypeRep either' (typeRep @Either) ->
612615
go reps (f rep)
613-
| otherwise -> error $ "type doesn't have enough instances " ++ show rep
616+
| otherwise -> error $ "[Monad] type doesn't have enough instances " ++ show rep
617+
go (SomeTypeRep rep : reps) (Applicable f) =
618+
if
619+
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @IO) -> go reps (f rep)
620+
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @Options.Parser) -> go reps (f rep)
621+
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @Maybe) -> go reps (f rep)
622+
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @[]) -> go reps (f rep)
623+
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @Tree) -> go reps (f rep)
624+
| Type.App either' _ <- rep,
625+
Just Type.HRefl <- Type.eqTypeRep either' (typeRep @Either) ->
626+
go reps (f rep)
627+
| otherwise -> error $ "[Applicative] type doesn't have enough instances " ++ show rep
628+
go (SomeTypeRep rep : reps) (Monoidal f) =
629+
if
630+
| Type.App either' _ <- rep,
631+
Just Type.HRefl <- Type.eqTypeRep either' (typeRep @Vector) ->
632+
go reps (f rep)
633+
| Type.App (Type.App either' _) _ <- rep,
634+
Just Type.HRefl <- Type.eqTypeRep either' (typeRep @Options.Mod) ->
635+
go reps (f rep)
636+
| Type.App either' _ <- rep,
637+
Just Type.HRefl <- Type.eqTypeRep either' (typeRep @[]) ->
638+
go reps (f rep)
639+
| Just Type.HRefl <- Type.eqTypeRep rep (typeRep @Text) -> go reps (f rep)
640+
| otherwise -> error $ "[Monoid] type doesn't have enough instances " ++ show rep
614641
go reps (GetOf k0 a0 t0 r0 f) =
615642
case makeAccessor k0 r0 a0 t0 of
616643
Just accessor -> go reps (f accessor)
@@ -632,6 +659,8 @@ tc (UForall _ _ _ fall _ _ reps0) _env = go reps0 fall
632659
ListOf {} -> "ListOf"
633660
OrdEqShow {} -> "OrdEqShow"
634661
Monadic {} -> "Monadic"
662+
Applicable {} -> "Applicable"
663+
Monoidal {} -> "Monoidal"
635664
GetOf {} -> "GetOf"
636665
SetOf {} -> "SetOf"
637666
ModifyOf {} -> "ModifyOf"
@@ -1275,7 +1304,11 @@ supportedLits =
12751304
-- Records
12761305
("hell:Hell.NilR", lit' NilR),
12771306
-- Nullary
1278-
("hell:Hell.Nullary", lit' Nullary)
1307+
("hell:Hell.Nullary", lit' Nullary),
1308+
-- Options
1309+
("Options.switch", lit' Options.switch),
1310+
("Options.strOption", lit' (Options.strOption @Text)),
1311+
("Options.strArgument", lit' (Options.strArgument @Text))
12791312
]
12801313
where
12811314
lit' :: forall a. (Type.Typeable a) => a -> (UTerm (), SomeTypeRep)
@@ -1340,7 +1373,12 @@ polyLits =
13401373
)
13411374
vars
13421375
ordEqShow = Set.fromList [''Ord, ''Eq, ''Show]
1343-
monadics = Set.fromList [''Functor, ''Applicative, ''Monad]
1376+
monadics = Set.fromList [''Monad]
1377+
-- When we add a type that is a Functor but not an
1378+
-- Applicative, we should add a Functor class or
1379+
-- this will try to raise it to an Applicative.
1380+
applicables = Set.fromList [''Functor, ''Applicative]
1381+
monoidals = Set.fromList [''Semigroup, ''Monoid]
13441382
finalExpr =
13451383
if
13461384
| string == "Record.get" ->
@@ -1382,6 +1420,8 @@ polyLits =
13821420
Just constraints'
13831421
| Set.isSubsetOf constraints' ordEqShow -> 'OrdEqShow
13841422
| Set.isSubsetOf constraints' monadics -> 'Monadic
1423+
| Set.isSubsetOf constraints' applicables -> 'Applicable
1424+
| Set.isSubsetOf constraints' monoidals -> 'Monoidal
13851425
_ -> error "I'm not sure what to do with this variable."
13861426
)
13871427
)
@@ -1443,10 +1483,16 @@ polyLits =
14431483
-- Operators
14441484
"$" (Function.$) :: forall a b. (a -> b) -> a -> b
14451485
"." (Function..) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
1486+
"<>" (<>) :: forall m. Semigroup m => m -> m -> m
14461487
-- Monad
14471488
"Monad.bind" (Prelude.>>=) :: forall m a b. (Monad m) => m a -> (a -> m b) -> m b
14481489
"Monad.then" (Prelude.>>) :: forall m a b. (Monad m) => m a -> m b -> m b
14491490
"Monad.return" return :: forall a m. (Monad m) => a -> m a
1491+
-- Applicative operations
1492+
"Applicative.pure" pure :: forall f a. Applicative f => a -> f a
1493+
"<*>" (<*>) :: forall f a b. Applicative f => f (a -> b) -> f a -> f b
1494+
"<$>" (<$>) :: forall f a b. Functor f => (a -> b) -> f a -> f b
1495+
"<**>" (Options.<**>) :: forall f a b. Applicative f => f a -> f (a -> b) -> f b
14501496
-- Monadic operations
14511497
"Monad.mapM_" mapM_ :: forall a m. (Monad m) => (a -> m ()) -> [a] -> m ()
14521498
"Monad.forM_" forM_ :: forall a m. (Monad m) => [a] -> (a -> m ()) -> m ()
@@ -1605,15 +1651,48 @@ polyLits =
16051651
"Process.runProcess" runProcess :: forall a b c. ProcessConfig a b c -> IO ExitCode
16061652
"Process.runProcess_" runProcess_ :: forall a b c. ProcessConfig a b c -> IO ()
16071653
"Process.setStdout" setStdout :: forall stdin stdout stdout' stderr. StreamSpec 'STOutput stdout' -> ProcessConfig stdin stdout stderr -> ProcessConfig stdin stdout' stderr
1608-
"Process.useHandleClose" useHandleClose :: forall (a :: StreamType). IO.Handle -> StreamSpec a ()
1609-
"Process.useHandleOpen" useHandleOpen :: forall (a :: StreamType). IO.Handle -> StreamSpec a ()
1654+
"Process.useHandleClose" useHandleClose :: forall (a :: StreamType). IO.Handle -> StreamSpec a ()
1655+
"Process.useHandleOpen" useHandleOpen :: forall (a :: StreamType). IO.Handle -> StreamSpec a ()
16101656
"Process.setWorkingDir" process_setWorkingDir :: forall a b c. Text -> ProcessConfig a b c -> ProcessConfig a b c
1657+
-- Options
1658+
"Options.execParser" Options.execParser :: forall a. Options.ParserInfo a -> IO a
1659+
"Options.info" Options.info :: forall a. Options.Parser a -> Options.InfoMod a -> Options.ParserInfo a
1660+
"Options.helper" Options.helper :: forall a. Options.Parser (a -> a)
1661+
"Options.fullDesc" Options.fullDesc :: forall a. Options.InfoMod a
1662+
"Options.flag" Options.flag :: forall a. a -> a -> Options.Mod Options.FlagFields a -> Parser a
1663+
"Options.flag'" Options.flag' :: forall a. a -> Options.Mod Options.FlagFields a -> Parser a
1664+
"Option.long" option_long :: forall a. Text -> Options.Mod Options.OptionFields a
1665+
"Option.help" options_help :: forall a. Text -> Options.Mod Options.OptionFields a
1666+
"Flag.help" options_help :: forall a. Text -> Options.Mod Options.FlagFields a
1667+
"Flag.long" flag_long :: forall a. Text -> Options.Mod Options.FlagFields a
1668+
"Option.value" option_value :: forall a. a -> Options.Mod Options.OptionFields a
1669+
"Argument.value" argument_value :: forall a. a -> Options.Mod Options.ArgumentFields a
1670+
"Argument.metavar" argument_metavar :: forall a. Text -> Options.Mod Options.ArgumentFields a
1671+
"Argument.help" options_help :: forall a. Text -> Options.Mod Options.ArgumentFields a
16111672
|]
16121673
)
16131674

16141675
--------------------------------------------------------------------------------
16151676
-- Internal-use only, used by the desugarer
16161677

1678+
argument_metavar :: forall a. Text -> Options.Mod Options.ArgumentFields a
1679+
argument_metavar = Options.metavar . Text.unpack
1680+
1681+
option_value :: forall a. a -> Options.Mod Options.OptionFields a
1682+
option_value = Options.value
1683+
1684+
argument_value :: forall a. a -> Options.Mod Options.ArgumentFields a
1685+
argument_value = Options.value
1686+
1687+
options_help :: forall f a. Text -> Options.Mod f a
1688+
options_help = Options.help . Text.unpack
1689+
1690+
option_long :: forall a. Text -> Options.Mod Options.OptionFields a
1691+
option_long = Options.long . Text.unpack
1692+
1693+
flag_long :: forall a. Text -> Options.Mod Options.FlagFields a
1694+
flag_long = Options.long . Text.unpack
1695+
16171696
cons' :: HSE.SrcSpanInfo -> UTerm ()
16181697
cons' = unsafeGetForall "List.cons"
16191698

0 commit comments

Comments
 (0)