{-# LANGUAGE FlexibleContexts, 
             MultiParamTypeClasses, 
             DeriveFunctor,
             TypeOperators,
             TypeSynonymInstances #-}

import Control.Monad.Except
import Control.Monad
import Data.Maybe
import Data.Either
import Prelude hiding (lookup)
import Data.Map hiding (map)

---------------------------------------------------

-- | if-the-else monadico y aplicativo

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM mb mt me = do b <- mb
                  if b then mt else me

ifA :: Applicative f => f Bool -> f a -> f a -> f a
ifA fb ft fe = cond <$> fb <*> ft <*> fe
  where
    cond b t e = if b then t else e

-- | IO como aplicativo (GHC.Base)

{-
instance Applicative IO where
  pure x = return x
  m <*> m' = do f <- m
                x <- m'
                return (f x)
-}

-- versión monádica
lecturaM = do xs <- getLine
              ys <- getLine
              return (xs++ys)

-- versión aplicativa
lecturaA = (++) <$> getLine <*> getLine                

-- | Listas como aplicativo (GHC.Base)

{-
instance Applicative [] where
  pure x = [x]
  fs <*> xs = [f x | f <- fs, x <- xs]
-}

ejL = [(+1),(+2)] <*> [1,2,3]

-- | Aplicativo diferente para listas (Control.Applicative)

newtype ZipList a = ZipList { getZipList :: [a] }
    deriving (Show, Eq, Functor)

instance Applicative ZipList where
    pure x = ZipList (repeat x)
    ZipList fs <*> ZipList xs = ZipList (zipWith ($) fs xs)

ejZipL1 = (+) <$> ZipList [1,2,3] <*> ZipList [3,2,1]

ejZipL2 = mod <$> ZipList [25,32,11] <*> ZipList [5,3,4]

ejZipL3 = max <$> pure 0 <*> ZipList [1,2,0,-3,-7]

ejZipL4 = (,,) <$> ZipList [1,2,3] <*> ZipList [4,5,6] <*> ZipList [7,8,9] 

{-
sequenceA :: Applicative f => [f a] -> f [a]
sequenceA [] = pure []
sequenceA (x:xs) = (:) <$> x <*> sequenceA xs
-}

transpose :: [[a]] -> [[a]]
transpose = getZipList . sequenceA . map ZipList

ejTrans = transpose [[1,2,3],[4,5,6],[7,8,9]]

-- | Evaluador de expresiones con error

data Exp = Num Int | Add Exp Exp | Div Exp Exp
  deriving Show

-- Es imposible definir un evaluador con errores solo usando un functor
-- aplicativo, es necesario tambien usar una monada. Esto se debe a que
-- es necesario inspeccionar el valor del denominador de una division 
-- y fallar en caso que sea cero. Esto no es posible de realizar con un 
-- functor aplicativo.

-- Este evaluador retorna Just un valor o Just una excepcion cuando ocurre 
-- una division por cero
evalErr :: Exp -> Maybe Int
evalErr (Num n)    = pure n
evalErr (Add e e') = (+) <$> evalErr e <*> evalErr e'
-- imposible de capturar con el aplicativo la division por cero
evalErr (Div e e') = div <$> evalErr e <*> evalErr e'

-- | Para capturar la division por cero debemos usar una monada

evalErrM :: Exp -> Maybe Int
evalErrM (Num n)    = pure n
evalErrM (Add e e') = (+) <$> evalErrM e <*> evalErrM e'
evalErrM (Div e e') = do x <- evalErrM e
                         y <- evalErrM e'
                         divM x y
  where
    divM x y = if y == 0 then Nothing -- throwError "division por cero"
                         else return (x `div` y)   

-- Expresiones ejemplo:
expOK   = Add (Num 1) (Num 2)
expDxZ  = Div expOK (Num 0)
expDxZ' = Add expDxZ expDxZ
-- retorna suma
ej1 = evalErr expOK 
-- retorna Just y cancela por division or cero
ej2 = evalErr expDxZ
-- retorna suma 
ej3 = evalErrM expOK
-- retorna Nothing
ej4 = evalErrM expDxZ

-- El mismo evaluador en terminos de MonadError
evalErrME :: MonadError String m => Exp -> m Int
evalErrME (Num n)    = pure n
evalErrME (Add e e') = (+) <$> evalErrME e <*> evalErrME e'
evalErrME (Div e e') = do x <- evalErrME e
                          y <- evalErrME e'
                          divM x y
  where
    divM x y = if y == 0 then throwError "division por cero"
                         else return (x `div` y)   

-- retorna suma
ej5 = evalErrME expOK  :: Either String Int -- setea instancia de MonadError
-- retorna el error
ej6 = evalErrME expDxZ :: Either String Int -- setea instancia de MonadError

-- | Aplicativo para acumular errores

data Failing e a = Success a | Failure e
  deriving (Functor,Show)

instance Monoid e => Applicative (Failing e) where
  pure a = Success a
  Success f <*> Success a  = Success (f a)
  Failure e <*> Success _  = Failure e
  Success _ <*> Failure e  = Failure e
  Failure e <*> Failure e' = Failure (e `mappend` e')

type Error    = Failing [ErrorMsg]
type ErrorMsg = String

failure :: e -> Failing [e] a
failure e = Failure [e]

-- La instancia Applicative (Failing e) no es una monada:
-- instance Monoid e => Monad (Failing e) where
--   return = Success
--   Failure e >>= f = ... no podemos aplicar f porque solo se aplica
--                         cuando la primer computacion retorna un
--                         valor (Success a). 

instance Monoid e => Monad (Failing e) where
  return = Success
  Success a >>= f = f a
  Failure e >>= f = Failure e

-- Con esta instancia de Monad (Failing e), <*> y ap se comportan diferente:
-- Failure a <*>  Failure b  =  Failure (a `mappend` b)
-- Failure a `ap` Failure b  =  Failure a
 
-- La siguiente instancia de Applicative iguala <*> y ap:
{-
instance Applicative (Failing e) where
  pure = Success
  Success f <*> Success a = Success (f a)
  Success f <*> Failure e = Failure e
  Failure e <*> _         = Failure e
-}

-- Evaluador de expresiones con variables

type ID = String
data ExpV = NumV Int | AddV ExpV ExpV | Var ID 
     deriving Show

-- ambiente de variables
type Env = Map ID Int 

evalV :: ExpV -> Env -> Error Int
evalV (NumV n)    env = pure n
evalV (AddV e e') env = (+) <$> evalV e env <*> evalV e' env
evalV (Var x)     env = fetch x env

fetch x env = case lookup x env of
                Just v  -> pure v
                Nothing -> failure (x ++ " no esta en env")

-- ambiente ejemplo
env0 = insert "x" 3 empty
-- retorna suma
ej7 = evalV (AddV (NumV 2) (Var "x")) env0
-- retorna falla
ej8 = evalV (AddV (Var "y") (Var "z")) env0

-- | Composicion de functores

newtype Compose f g a = Compose { getCompose :: f (g a) }

-- operador de composicion de functores
infixr :.: 
type f :.: g = Compose f g

-- La composicion de functores es un functor 
instance (Functor f, Functor g) => Functor (f :.: g) where
    fmap f (Compose x) = Compose (fmap (fmap f) x)

-- La composicion de functores aplicativos es un functor aplicativo
instance (Applicative f, Applicative g) => Applicative (f :.: g) where
    pure x = Compose (pure (pure x))
    Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)   

-- | Composicion de los functores Reader y Error. 

-- equivale a: type Reader a = Env -> a
type Reader      = (->) Env      
-- composicion de functores Reader y Error   
-- equivale a: type ReaderError a = Env -> Error a
type ReaderError = Reader :.: Error 

-- | Reescribimos evalV en terminos del functor compuesto 

evalVRE :: ExpV -> ReaderError Int
evalVRE (NumV n)    = pure n
evalVRE (AddV e e') = (+) <$> evalVRE e <*> evalVRE e'
evalVRE (Var x)     = Compose $ fetch x

-- retorna suma
ej9  = getCompose (evalVRE (AddV (NumV 2) (Var "x"))) env0
-- retorna falla
ej10 = getCompose (evalVRE (AddV (Var "y") (Var "z"))) env0

-- | Monada de estado

newtype State s a = State (s -> (a, s))

runState :: State s a -> (s -> (a, s))
runState (State f) = f

instance Functor (State s) where
  fmap f (State g) = State $ \s -> let (a,s') = g s in (f a,s')

instance Applicative (State s) where
  pure a = State $ \s -> (a, s)
  (State g) <*> (State k) = State $ \s -> let (f,s') = g s
                                              (a,s'') = k s'
                                          in (f a,s'')

instance Monad (State s) where
  return a = State $ \s -> (a, s)

  m >>= f  = State $ \s ->  let (a, s') = runState m s
                            in  runState (f a) s'

-- funciones sobre estado

get :: State s s
get = State $ \s -> (s, s)

put :: s -> State s ()
put s  = State $ \_ -> ((), s)

modify :: (s -> s) -> State s ()
modify f = do  s <- get
               put (f s)

-- retorna el valor final de la computacion
evalState :: State s a -> s -> a
evalState m s = fst $ runState m s

-- retorna el estado final de la computacion
execState :: State s a -> s -> s
execState m s = snd $ runState m s        

-- | Contar numero de sumas en una expresion (implementado con monadas)

data ExpS = NumS Int | AddS ExpS ExpS

tick :: State Int ()
tick = modify (+1)       

evalS :: ExpS -> State Int Int
evalS (NumS n)    = return n
evalS (AddS e e') = do a <- evalS e
                       b <- evalS e'
                       tick
                       return (a + b)

nroSumas :: ExpS -> Int
nroSumas e = execState (evalS e) 0 

-- Lo mismo usando un functor aplicativo 

evalSApp :: ExpS -> State Int Int
evalSApp (NumS n)    = pure n
-- ignoramos el valor que retorna tick usando el operador <*
evalSApp (AddS e e') = (+) <$> evalSApp e <*> evalSApp e' <* tick
  
nroSumasApp e = execState (evalSApp e) 0

-- | Expresiones con asignacion

data ExpA = NumA Int | AddA ExpA ExpA | VarA ID | AssignA ID ExpA
     deriving Show

-- al igual que los ambientes, implementamos la memoria usando un Map
type Store = Map ID Int

-- Como en el caso monadico, el evaluador retorna un entero y modifica 
-- el store. Si una variable no esta en el store el evaluador cancela.  

evalA :: ExpA -> State Store Int
evalA (NumA n)      = pure n
evalA (AddA e e')   = (+) <$> evalA e <*> evalA e'
-- retorna el valor de x en el store
evalA (VarA x)      = (\s -> s ! x) <$> get
-- implementacion monadica 
evalA (AssignA x e) = do v <- evalA e
                         modify (\s -> insert x v s)
                         return v
-- implementacion aplicativa                         
-- evalA (AssignA x e) = k x <*> evalA e
   -- el tipo de k x es State Store (Int -> a)
   -- no hay forma de que k x modifique el estado con el valor
   -- retornado por evalA e.

-- memoria ejemplo
sto0 :: Store
sto0 = insert "x" 3 empty   

ej11  = evalState (evalA (AddA (NumA 2) (VarA "x"))) sto0 
ej11' = execState (evalA (AddA (NumA 2) (VarA "x"))) sto0

-- cancela por no encontrar la variable y en la memoria
ej12  = evalState (evalA (AddA (NumA 2) (VarA "y"))) sto0
ej12' = execState (evalA (AddA (NumA 2) (VarA "y"))) sto0

ej13  = evalState (evalA (AddA (NumA 2) (AssignA "x" (NumA 5)))) sto0
ej13' = execState (evalA (AddA (NumA 2) (AssignA "x" (NumA 5)))) sto0

ej14  = evalState (evalA (AssignA "y" (AddA (NumA 2) (AssignA "x" (NumA 5)))))
                  empty
ej14' = execState (evalA (AssignA "y" (AddA (NumA 2) (AssignA "x" (NumA 5)))))
                  empty

-- | Composicion de los functores State y Error.

-- equivale a: type StateError a = State Store (Error a)
type StateError = State Store :.: Error

evalASE :: ExpA -> StateError Int
evalASE (NumA n)      = pure n
evalASE (AddA e e')   = (+) <$> evalASE e <*> evalASE e'
evalASE (VarA x)      = Compose $ fetchS x
evalASE (AssignA x e) = Compose $
                           do m <- getCompose $ evalASE e
                              case m of
                                Success v   -> do modify (\s -> insert x v s)
                                                  return (Success v)
                                Failure msg -> return (Failure msg) 

fetchS :: ID -> State Store (Error Int)                                          
fetchS x = State $ \sto -> case lookup x sto of
                             Just v  -> (Success v,sto)
                             Nothing -> (failure (x ++ " no esta en env"),sto)

runSE :: StateError a -> Env -> Error a
runSE (Compose f) sto = evalState f sto

-- retorna falla
ej15 = runSE (evalASE (AddA (NumA 2) (VarA "y"))) sto0
-- retorna falla
ej16 = runSE (evalASE (AddA (VarA "z") (VarA "y"))) sto0
-- retorna suma
ej17 = runSE (evalASE (AddA (NumA 2) (AssignA "x" (NumA 5)))) sto0