{-# LANGUAGE RankNTypes,
             MultiParamTypeClasses,
             FunctionalDependencies,
             FlexibleInstances,
             UndecidableInstances,
             FlexibleContexts,
             CPP #-}

#define DEMO(p,i) demo "p" i p

module Text.ParserCombinators.UU.Idioms where

import Text.ParserCombinators.UU
import  Text.ParserCombinators.UU.BasicInstances hiding (Parser)
import Text.ParserCombinators.UU.Utils
import Text.ParserCombinators.UU.Demo.Examples hiding (show_demos)
import qualified Data.ListLike as LL
import Control.Applicative 

data IF = IF
data THEN = THEN
data ELSE = ELSE
data FI = FI
data OR = OR


data String' = String' {String' -> String
fromStr :: String}

-- | The  `Ii` is to be pronounced as @stop@
data Ii = Ii 

-- | The function `iI` is to be pronounced as @start@
iI ::Idiomatic  i (a -> a) g => g
iI :: g
iI = P i (a -> a) -> g
forall st f g. Idiomatic st f g => P st f -> g
idiomatic ((a -> a) -> P i (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id)

class Idiomatic st f g  | g -> f st  where
    idiomatic :: P st f -> g
instance  Idiomatic st x  (Ii -> P st x) where
    idiomatic :: P st x -> Ii -> P st x
idiomatic P st x
ix Ii
Ii = P st x
ix
{-
instance Idiomatic st (a->a) g   => Idiomatic st g OR  where
    idiomatic ix OR = (ix <|>) . idiomatic (pure id)
-}

instance  Idiomatic st f g  => Idiomatic  st (a -> f) (P  st a -> g) where
    idiomatic :: P st (a -> f) -> P st a -> g
idiomatic P st (a -> f)
isf P st a
is = P st f -> g
forall st f g. Idiomatic st f g => P st f -> g
idiomatic (P st (a -> f)
isf P st (a -> f) -> P st a -> P st f
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P st a
is)



instance Idiomatic st f g => Idiomatic st ((a -> b) -> f)  ((a -> b) -> g) where
    idiomatic :: P st ((a -> b) -> f) -> (a -> b) -> g
idiomatic P st ((a -> b) -> f)
isf a -> b
f = P st f -> g
forall st f g. Idiomatic st f g => P st f -> g
idiomatic (P st ((a -> b) -> f)
isf P st ((a -> b) -> f) -> P st (a -> b) -> P st f
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((a -> b) -> P st (a -> b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> b
f))
instance (Idiomatic  (Str Char state loc) f g, IsLocationUpdatedBy loc Char, LL.ListLike state Char) 
       => Idiomatic  (Str Char state loc) f (String -> g) where
    idiomatic :: P (Str Char state loc) f -> String -> g
idiomatic P (Str Char state loc) f
isf String
str = P (Str Char state loc) f -> g
forall st f g. Idiomatic st f g => P st f -> g
idiomatic (P (Str Char state loc) f
isf P (Str Char state loc) f
-> P (Str Char state loc) String -> P (Str Char state loc) f
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P (Str Char state loc) String -> P (Str Char state loc) String
forall a. ParserTrafo a a
lexeme (String -> P (Str Char state loc) String
forall loc state a.
(Show a, Eq a, IsLocationUpdatedBy loc a, ListLike state a) =>
[a] -> P (Str a state loc) [a]
pToken String
str))
instance  (Idiomatic (Str Char state loc) f g, IsLocationUpdatedBy loc Char, LL.ListLike state Char) 
      =>   Idiomatic (Str Char state loc) f (Char -> g) where
    idiomatic :: P (Str Char state loc) f -> Char -> g
idiomatic P (Str Char state loc) f
isf Char
c = P (Str Char state loc) f -> g
forall st f g. Idiomatic st f g => P st f -> g
idiomatic (P (Str Char state loc) f
isf P (Str Char state loc) f
-> P (Str Char state loc) Char -> P (Str Char state loc) f
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P (Str Char state loc) Char -> P (Str Char state loc) Char
forall a. ParserTrafo a a
lexeme (Char -> P (Str Char state loc) Char
forall a loc state.
(Eq a, Show a, IsLocationUpdatedBy loc a, ListLike state a) =>
a -> P (Str a state loc) a
pSym Char
c))
instance Idiomatic st f g =>    Idiomatic st (a -> f) (IF -> Bool -> THEN -> P st a -> ELSE -> P st a -> FI -> g) where
    idiomatic :: P st (a -> f)
-> IF -> Bool -> THEN -> P st a -> ELSE -> P st a -> FI -> g
idiomatic P st (a -> f)
isf IF
IF Bool
b THEN
THEN P st a
t ELSE
ELSE P st a
e FI
FI = P st f -> g
forall st f g. Idiomatic st f g => P st f -> g
idiomatic (P st (a -> f)
isf P st (a -> f) -> P st a -> P st f
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if Bool
b then P st a
t else P st a
e))
 

-- | The idea of the Idiom concept is that  sequential composition operators can be inferred from the type 
--   of the various operands
--
-- >>> run (iI (+) '(' pNatural "plus"  pNatural ')' Ii) "(2 plus 3"
--   Result: 5
--    Correcting steps: 
--      Inserted  ')' at position LineColPos 0 4 4 expecting one of [')', Whitespace, '0'..'9']
--
pNat :: Parser Int
pNat :: Parser Int
pNat = Parser Int
forall a. Num a => Parser a
pNatural

show_demos :: IO ()
show_demos :: IO ()
show_demos =  String -> String -> Parser Int -> IO ()
forall r.
Show r =>
String -> String -> P (Str Char String LineColPos) r -> IO ()
demo  String
"(+) <$> (iI (+) '(' pNat \"plus\" IF True THEN pNat ELSE pNat FI ')' Ii)  <* lexeme (pSym '+') <*>  pNat)" String
"(2 plus 3) + 8"  
                    (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int)
-> Parser Int -> P (Str Char String LineColPos) (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int -> Int -> Int)
-> Char
-> Parser Int
-> String
-> IF
-> Bool
-> THEN
-> Parser Int
-> ELSE
-> Parser Int
-> FI
-> Char
-> Ii
-> Parser Int
forall i a g. Idiomatic i (a -> a) g => g
iI Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Char
'(' Parser Int
pNat  String
"plus"  IF
IF Bool
True THEN
THEN Parser Int
pNat ELSE
ELSE Parser Int
pNat FI
FI Char
')' Ii
Ii) P (Str Char String LineColPos) (Int -> Int)
-> P (Str Char String LineColPos) Char
-> P (Str Char String LineColPos) (Int -> Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P (Str Char String LineColPos) Char
-> P (Str Char String LineColPos) Char
forall a. ParserTrafo a a
lexeme (Char -> P (Str Char String LineColPos) Char
forall a loc state.
(Eq a, Show a, IsLocationUpdatedBy loc a, ListLike state a) =>
a -> P (Str a state loc) a
pSym Char
'+') P (Str Char String LineColPos) (Int -> Int)
-> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>  Parser Int
pNat)