module Feldspar.Data.Option
( OptionT
, Option
, none
, some
, guardO
, guarded
, rebuildOption
, option
, caseOption
, fromSome
, optionM
, caseOptionM
, fromSomeM
, optionT
, caseOptionT
, fromSomeT
) where
import Prelude ()
import Control.Monad.Operational.Higher
import Control.Monad.Identity
import Control.Monad.Trans
import Language.Syntactic
import Feldspar
import Feldspar.Representation
data Opt fs a
where
None :: String -> Opt (Param1 prog) a
Guard :: String -> Data Bool -> Opt (Param1 prog) ()
instance HFunctor Opt
where
hfmap f (None msg) = None msg
hfmap f (Guard msg c) = Guard msg c
newtype OptionT m a = Option { unOption :: ProgramT Opt Param0 m a }
deriving (Functor, Applicative, Monad, MonadTrans)
type Option = OptionT Identity
instance MonadComp m => MonadComp (OptionT m)
where
liftComp = lift . liftComp
iff c t f = do
okr <- initRef true
lift $ iff c
(optionT (\_ -> setRef okr false) return t)
(optionT (\_ -> setRef okr false) return f)
ok <- unsafeFreezeRef okr
guardO "iff: none" ok
for rng body = do
okr <- initRef true
lift $ for rng $ \i ->
optionT (\_ -> setRef okr false >> break) return (body i)
ok <- unsafeFreezeRef okr
guardO "for: none" ok
while cont body = do
okr <- initRef true
lift $ while
(cont' okr)
(optionT (\_ -> setRef okr false >> break) return body)
ok <- unsafeFreezeRef okr
guardO "while: none" ok
where
cont' okr = do
cr <- newRef
caseOptionT (cont >>= setRef cr) (\_ -> setRef okr false >> setRef cr false) return
unsafeFreezeRef cr
instance Syntax a => Syntactic (Option a)
where
type Domain (Option a) = FeldDomain
type Internal (Option a) = (Bool, Internal a)
desugar = unData . option
(\_ -> Feldspar.desugar (false,example :: (Data (Internal a))))
(\a -> Feldspar.desugar (true,a))
sugar o = guarded "sugar: none" valid a
where
(valid,a) = Feldspar.sugar $ Data o
none :: String -> OptionT m a
none = Option . singleton . None
some :: Monad m => a -> OptionT m a
some = return
guardO :: String -> Data Bool -> OptionT m ()
guardO msg c = Option $ singleton $ Guard msg c
guarded :: Monad m => String -> Data Bool -> a -> OptionT m a
guarded msg c a = guardO msg c >> return a
rebuildOption :: Monad m => Option a -> OptionT m a
rebuildOption = interpretWithMonad go . unOption
where
go :: Opt (Param1 (OptionT m)) a -> OptionT m a
go (None msg) = none msg
go (Guard msg c) = guardO msg c
option :: Syntax b
=> (String -> b)
-> (a -> b)
-> Option a
-> b
option noneCase someCase (Option opt) = go (view opt)
where
go (Return a) = someCase a
go (None msg :>>= k) = noneCase msg
go (Guard msg c :>>= k) = cond c (go $ view $ k ()) (noneCase msg)
caseOption :: Syntax b
=> Option a
-> (String -> b)
-> (a -> b)
-> b
caseOption o n s = option n s o
fromSome :: Syntax a => Option a -> a
fromSome = option (const example) id
optionM :: MonadComp m
=> (String -> m ())
-> (a -> m ())
-> Option a
-> m ()
optionM noneCase someCase (Option opt) = go $ view opt
where
go (Return a) = someCase a
go (None msg :>>= k) = noneCase msg
go (Guard msg c :>>= k) = iff c (go $ view $ k ()) (noneCase msg)
caseOptionM :: MonadComp m
=> Option a
-> (String -> m ())
-> (a -> m ())
-> m ()
caseOptionM o n s = optionM n s o
fromSomeM :: (Syntax a, MonadComp m) => Option a -> m a
fromSomeM opt = do
r <- newRef
caseOptionM opt
(const $ return ())
(setRef r)
unsafeFreezeRef r
optionT :: MonadComp m
=> (String -> m ())
-> (a -> m ())
-> OptionT m a
-> m ()
optionT noneCase someCase (Option opt) = go =<< viewT opt
where
go (Return a) = someCase a
go (None msg :>>= k) = noneCase msg
go (Guard msg c :>>= k) = iff c (go =<< viewT (k ())) (noneCase msg)
caseOptionT :: MonadComp m
=> OptionT m a
-> (String -> m ())
-> (a -> m ())
-> m ()
caseOptionT o n s = optionT n s o
fromSomeT :: (Syntax a, MonadComp m) => OptionT m a -> m a
fromSomeT opt = do
r <- newRef
caseOptionT opt
(const $ return ())
(setRef r)
unsafeFreezeRef r