{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

--
-- Copyright (c) 2009-2011, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Option where



import qualified Prelude
import Control.Applicative (Applicative(..))
import Control.Monad

import Language.Syntactic

import Feldspar hiding (sugar,desugar,resugar)



data Option a = Option { isSome :: Data Bool, fromSome :: a }

instance Syntax a => Syntactic (Option a)
  where
    type Domain (Option a)   = FeldDomain
    type Internal (Option a) = (Bool, Internal a)
    desugar = desugar . desugarOption . fmap resugar
    sugar   = fmap resugar . sugarOption . sugar

instance Functor Option
  where
    fmap f opt = opt {fromSome = f (fromSome opt)}

instance Applicative Option
  where
    pure  = return
    (<*>) = ap

instance Monad Option
  where
    return = some
    a >>= f = b { isSome = isSome a ? isSome b $ false }
      where
        b = f (fromSome a)



-- | One-layer desugaring of 'Option'
desugarOption :: Type a => Option (Data a) -> Data (Bool,a)
desugarOption a = resugar (isSome a, fromSome a)

-- | One-layer sugaring of 'Option'
sugarOption :: Type a => Data (Bool,a) -> Option (Data a)
sugarOption (resugar -> (valid,a)) = Option valid a

some :: a -> Option a
some = Option true

none :: Syntax a => Option a
none = Option false (err "fromSome: none")

option :: Syntax b => b -> (a -> b) -> Option a -> b
option noneCase someCase opt = isSome opt
    ? someCase (fromSome opt)
    $ noneCase

oplus :: Syntax a => Option a -> Option a -> Option a
oplus a b = isSome a ? a $ b



--------------------------------------------------------------------------------
-- * Conditional choice operator
--------------------------------------------------------------------------------

-- http://zenzike.com/posts/2011-08-01-the-conditional-choice-operator

-- | Conditional choice operator. Can be used together with '<?' to write
-- guarded choices as follows:
--
-- > prog :: Data Index -> Data Index
-- > prog a
-- >     =  a+1 <? a==0
-- >     ?> a+2 <? a==1
-- >     ?> a+3 <? a==2
-- >     ?> a+4 <? a==3
-- >     ?> a+5
(?>) :: Data Bool -> a -> Option a
cond ?> a = Option (not cond) a

(<?) :: Syntax a => a -> Option a -> a
a <? b = option a id b

infixr 0 <?
infixr 0 ?>