{-# LANGUAGE CPP,
             FlexibleContexts,
             FlexibleInstances,
             UndecidableInstances,
             TypeFamilies #-}
module Language.Hakaru.Runtime.CmdLine where

import qualified Data.Vector.Unboxed             as U
import qualified System.Random.MWC               as MWC
import           Control.Monad                   (liftM, ap, forever)

#if __GLASGOW_HASKELL__ < 710
import           Data.Functor
import           Control.Applicative             (Applicative(..))
#endif

newtype Measure a = Measure { Measure a -> GenIO -> IO (Maybe a)
unMeasure :: MWC.GenIO -> IO (Maybe a) }

instance Functor Measure where
    fmap :: (a -> b) -> Measure a -> Measure b
fmap  = (a -> b) -> Measure a -> Measure b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
    {-# INLINE fmap #-}

instance Applicative Measure where
    pure :: a -> Measure a
pure a
x = (GenIO -> IO (Maybe a)) -> Measure a
forall a. (GenIO -> IO (Maybe a)) -> Measure a
Measure ((GenIO -> IO (Maybe a)) -> Measure a)
-> (GenIO -> IO (Maybe a)) -> Measure a
forall a b. (a -> b) -> a -> b
$ \GenIO
_ -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    {-# INLINE pure #-}
    <*> :: Measure (a -> b) -> Measure a -> Measure b
(<*>)  = Measure (a -> b) -> Measure a -> Measure b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    {-# INLINE (<*>) #-}

instance Monad Measure where
    return :: a -> Measure a
return  = a -> Measure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}
    Measure a
m >>= :: Measure a -> (a -> Measure b) -> Measure b
>>= a -> Measure b
f = (GenIO -> IO (Maybe b)) -> Measure b
forall a. (GenIO -> IO (Maybe a)) -> Measure a
Measure ((GenIO -> IO (Maybe b)) -> Measure b)
-> (GenIO -> IO (Maybe b)) -> Measure b
forall a b. (a -> b) -> a -> b
$ \GenIO
g -> do
                          Just a
x <- Measure a -> GenIO -> IO (Maybe a)
forall a. Measure a -> GenIO -> IO (Maybe a)
unMeasure Measure a
m GenIO
g
                          Measure b -> GenIO -> IO (Maybe b)
forall a. Measure a -> GenIO -> IO (Maybe a)
unMeasure (a -> Measure b
f a
x) GenIO
g
    {-# INLINE (>>=) #-}

makeMeasure :: (MWC.GenIO -> IO a) -> Measure a
makeMeasure :: (GenIO -> IO a) -> Measure a
makeMeasure GenIO -> IO a
f = (GenIO -> IO (Maybe a)) -> Measure a
forall a. (GenIO -> IO (Maybe a)) -> Measure a
Measure ((GenIO -> IO (Maybe a)) -> Measure a)
-> (GenIO -> IO (Maybe a)) -> Measure a
forall a b. (a -> b) -> a -> b
$ \GenIO
g -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenIO -> IO a
f GenIO
g
{-# INLINE makeMeasure #-}

-- A class of types that can be parsed from command line arguments
class Parseable a where
  parse :: String -> IO a

instance Parseable Int where
  parse :: String -> IO Int
parse = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (String -> Int) -> String -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read

instance Parseable Double where
  parse :: String -> IO Double
parse = Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> (String -> Double) -> String -> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double
forall a. Read a => String -> a
read

instance (U.Unbox a, Parseable a) => Parseable (U.Vector a) where
  parse :: String -> IO (Vector a)
parse String
s = [a] -> Vector a
forall a. Unbox a => [a] -> Vector a
U.fromList ([a] -> Vector a) -> IO [a] -> IO (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((String -> IO a) -> [String] -> IO [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO a
forall a. Parseable a => String -> IO a
parse) ([String] -> IO [a]) -> IO [String] -> IO [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
s))

instance (Read a, Read b) => Parseable (a, b) where
  parse :: String -> IO (a, b)
parse = (a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, b) -> IO (a, b)) -> (String -> (a, b)) -> String -> IO (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (a, b)
forall a. Read a => String -> a
read

{- Make main needs to recur down the function type while at the term level build
-- up a continuation of parses and partial application of the function
-}
class MakeMain p where
  makeMain :: p -> [String] -> IO ()

instance {-# OVERLAPPABLE #-}
         Show a => MakeMain a where
  makeMain :: a -> [String] -> IO ()
makeMain a
p [String]
_ = a -> IO ()
forall a. Show a => a -> IO ()
print a
p

instance Show a => MakeMain (Measure a) where
  makeMain :: Measure a -> [String] -> IO ()
makeMain Measure a
p [String]
_ = IO (Gen RealWorld)
IO GenIO
MWC.createSystemRandom IO (Gen RealWorld) -> (Gen RealWorld -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Gen RealWorld
gen ->
                   IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                     Maybe a
ms <- Measure a -> GenIO -> IO (Maybe a)
forall a. Measure a -> GenIO -> IO (Maybe a)
unMeasure Measure a
p Gen RealWorld
GenIO
gen
                     case Maybe a
ms of
                       Maybe a
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                       Just a
s  -> a -> IO ()
forall a. Show a => a -> IO ()
print a
s

instance (Parseable a, MakeMain b)
         => MakeMain (a -> b) where
  makeMain :: (a -> b) -> [String] -> IO ()
makeMain a -> b
p (String
a:[String]
as) = do a
a' <- String -> IO a
forall a. Parseable a => String -> IO a
parse String
a
                         b -> [String] -> IO ()
forall p. MakeMain p => p -> [String] -> IO ()
makeMain (a -> b
p a
a') [String]
as
  makeMain a -> b
_ [] = String -> IO ()
forall a. HasCallStack => String -> a
error String
"not enough arguments"