module PrintParseArrows where
import ConstructorName

pc :: (ArrowInt q, Regular d) => q a () -> q (d a) ()
pc c = fc c (pc c) <<< arr out
fc :: (ArrowInt q, Bifunctor f) => q a () -> q b () -> q (f a b) () 
fc p r = (\f-> (fcSum p r >>> printCon f) 
                 `asTypeOf` arr f) undefined

printCon :: (Bifunctor f, ArrowInt q) => (f a b -> ()) -> q Int ()
printCon f = printConstrNum ((fnoconstrs `asTypeOf` (const 1 . f)) undefined)

polytypic fcSum :: ArrowInt q => q a () -> q b () -> q (f a b) Int
  = \p r -> case f of
      g + h   ->  arr innNat     <<< (fcProd p r <+> fcSum p r)
      f       ->  arr (\() -> 0) <<<  fcProd p r

polytypic fcProd :: ArrowInt q => q a () -> q b () -> q (f a b) () 
  = \p r -> case f of
      g * h   -> arr (\((),())->()) <<< (fcProd p r <** fcProd p r)
      Empty   -> arr id
      Par     -> p
      Rec     -> r
      d @ g   -> pc (fcProd p r)

pu :: (ArrowInt q, Regular d) => q () a -> q () (d a)
pu u = fu u (pu u) >>> arr inn

fu :: (ArrowInt q, Bifunctor f) => q () a -> q () b -> q () (f a b) 
fu p r = (\f-> (fuSum p r <<< parseCon f) 
                 `asTypeOf` arr f) undefined

parseCon :: (Bifunctor f, ArrowInt q) => (() -> f a b) -> q () Int
parseCon f = parseConstrNum (fnoconstrs (f undefined))

fnoconstrs :: Bifunctor f => f a b -> Int
fnoconstrs x = length (fconstructors `asTypeOf` [x])

polytypic fuSum :: ArrowInt q => q () a -> q () b -> q Int (f a b)
  = \p r -> case f of
      g + h   ->  arr outNat     >>> (fuProd p r <+> fuSum p r)
      f       ->  arr (\0 -> ()) >>> fuProd p r

polytypic fuProd :: ArrowInt q => q () a -> q () b -> q () (f a b)
  = \p r -> case f of
      g * h   -> arr (\()->((),())) >>> (fuProd p r **> fuProd p r)
      Empty   -> arr id
      Par     -> p
      Rec     -> r
      d @ g   -> pu (fuProd p r)

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

-- Simulering av data Nat = Z | S Nat med Int
innNat :: Either () Int -> Int
outNat :: Int -> Either () Int
innNat = either (const 0) (\n->1+n)
outNat n = case n of
             0 -> Left ()
             m -> Right (m-1)
 
----------------------------------------------------------------
{-
Lessons learned by writing ReadShow:

fshow :: (ArrowInt q, Bifunctor f) => q a () -> q b () -> q (f a b) () 
fread :: (ArrowInt q, Bifunctor f) => q () c -> q () d -> q () (f c d) 
fshow p r = fshowSum p r >>> printCon
fread p r = freadSum p r <<< parseCon

printCon :: (Bifunctor f, ArrowInt q) => q (f a b) ()
printCon = arr fconstructorName >>> printConstr
parseCon :: (Bifunctor f, ArrowInt q) => q () (f a b)
parseCon = arr name2fconstructor <<< parseConstr

-- then the Sum case must (cheat to) preserve the functor type 
--  (using an explicit type and arr (const undefined) or similar)
-}
{-
-- Alternative equivalent definitions
pc c = fixA   (fc c)
pu u = unfixA (fu u)
fixA   :: (Regular d, ArrowInt q) =>
    (q (d a) b -> q (FunctorOf d a (d a)) b) -> q (d a) b
fixA   f = outA >>> f (fixA   f)
unfixA :: (Regular d, ArrowInt q) =>
    (q b (d a) -> q b (FunctorOf d a (d a))) -> q b (d a)
unfixA f = innA <<< f (unfixA f)
pc = fixA   . fc
pu = unfixA . fu
-}
----------------------------------------------------------------
-- program fusion: (>>>) is abbreviated with (;)
--   pidA (c;u)         = pc c ; pu u
--   fidA (c;u) (c';u') = fc c c' ; fu u u'
-- It turns out that pidA = pmapAr (or pmapAl)