{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators, TypeFamilies, ExistentialQuantification, FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds, StandaloneDeriving, ViewPatterns #-}
{-# LANGUAGE DefaultSignatures, MultiParamTypeClasses #-}

-- Okay
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}

{-# OPTIONS_GHC -Wall #-}

-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
-- {-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

----------------------------------------------------------------------
-- |
-- Module      :  Run
-- Copyright   :  (c) 2016 Conal Elliott
-- 
-- Maintainer  :  conal@tabula.com
-- Stability   :  experimental
-- 
-- Run a test: reify, CCC, circuit
----------------------------------------------------------------------

module ConCat.RunCircuit
  ( Okay, go,go',goSep,run,runSep,ranksep -- ,goM,goM',goMSep
  , (:>)) where

-- TODO: clean up interfaces.

import Prelude

import Control.Monad (when)

import ConCat.AltCat (toCcc,Uncurriable(..),Ok,Ok2) -- unitArrow
import ConCat.Circuit (Attr,mkGraph,writeDot,displayDot,(:>),GenBuses)

-- import ConCat.Netlist (saveAsVerilog)
-- import ConCat.Mealy (Mealy(..,asFun)

ranksep :: Double -> Attr
ranksep :: Double -> Attr
ranksep Double
n = (String
"ranksep",Double -> String
forall a. Show a => a -> String
show Double
n)

-- type Okay = Uncurriable (:>) ()

-- type Okay = Yes2
-- type Okay a b = GenBuses a
type Okay a b = (Uncurriable (:>) a b, GenBuses (UncDom a b), Ok (:>) (UncRan a b))

go :: Okay a b => String -> (a -> b) -> IO ()
-- go name = go' name []
go :: forall a b. Okay a b => String -> (a -> b) -> IO ()
go String
_ a -> b
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"go: not implemented"
{-# NOINLINE go #-}

go' :: Okay a b => String -> [Attr] -> (a -> b) -> IO ()
-- go' name attrs f = run name attrs (toCcc (uncurries (unitArrow f)))
go' :: forall a b. Okay a b => String -> [Attr] -> (a -> b) -> IO ()
go' String
_ [Attr]
_ a -> b
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"go': not implemented"
{-# NOINLINE go' #-}

goSep :: Okay a b => String -> Double -> (a -> b) -> IO ()
-- goSep name s = go' name [ranksep s]
goSep :: forall a b. Okay a b => String -> Double -> (a -> b) -> IO ()
goSep String
_ Double
_ a -> b
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"goSep: not implemented"
{-# NOINLINE goSep #-}

-- Use rules instead of INLINE so that GHC will "inline" these definitions
-- before inlining begins. Otherwise, we'd lose our "primitives" before they can
-- be reified.

-- It's crucial that these error definitions are not CAFs. Otherwise, case
-- alternatives disappear. See inquiry and explanation:
-- <http://haskell.1045720.n5.nabble.com/Disappearing-case-alternative-td5832042.html>

{-# RULES

"go'"   forall name attrs f . go' name attrs f = run name attrs (uncurries (toCcc f))
"go"    forall name         . go name          = go' name []
"goSep" forall name s       . goSep name s     = go' name [ranksep s]

 #-}

-- genVerilog :: Bool
-- genVerilog = False -- True

genPdf :: Bool
genPdf :: Bool
genPdf = Bool
True -- False

-- showPretty :: Bool
-- showPretty = False -- True

showGraph :: Bool
showGraph :: Bool
showGraph = Bool
False -- True

-- Run an example: reify, CCC, circuit.
run :: (GenBuses a, Ok (:>) b) => String -> [Attr] -> (a :> b) -> IO ()
run :: forall a b.
(GenBuses a, Ok (:>) b) =>
String -> [Attr] -> (a :> b) -> IO ()
run String
name [Attr]
attrs a :> b
circ = do -- when showPretty $ putStrLn (name ++ " = " ++ show e)
                         String -> [Attr] -> (a :> b) -> IO ()
forall a b. Ok2 (:>) a b => String -> [Attr] -> (a :> b) -> IO ()
outGV String
name [Attr]
attrs a :> b
circ
{-# NOINLINE run #-}

runSep :: (Ok2 (:>) a b) => String -> Double -> (a :> b) -> IO ()
runSep :: forall a b. Ok2 (:>) a b => String -> Double -> (a :> b) -> IO ()
runSep String
name Double
s = String -> [Attr] -> (a :> b) -> IO ()
forall a b.
(GenBuses a, Ok (:>) b) =>
String -> [Attr] -> (a :> b) -> IO ()
run String
name [Double -> Attr
ranksep Double
s]

-- Diagram and Verilog
outGV :: Ok2 (:>) a b => String -> [Attr] -> (a :> b) -> IO ()
outGV :: forall a b. Ok2 (:>) a b => String -> [Attr] -> (a :> b) -> IO ()
outGV String
name [Attr]
attrs a :> b
circ =
  do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showGraph (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"outGV: Graph \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Graph -> String
forall a. Show a => a -> String
show Graph
g
     String -> [Attr] -> Graph -> IO ()
writeDot String
name [Attr]
attrs Graph
g
     -- Cap the size so that LaTeX doesn't choke and PDF viewers allow more
     -- zooming out.
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
genPdf (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Attr -> String -> IO ()
displayDot (String
"pdf",String
"-Gsize=10,10") String
name
     -- displayDot ("svg","") 
     -- displayDot ("png","-Gdpi=200")
     -- when genVerilog $ saveAsVerilog g
 where
   g :: Graph
g = (a :> b) -> Graph
forall a b. Ok2 (:>) a b => (a :> b) -> Graph
mkGraph a :> b
circ
{-# NOINLINE outGV #-}

-- TODO: Move file-saving code from outD and saveVerilog to here.

#if 0

{--------------------------------------------------------------------
    State machines
--------------------------------------------------------------------}

goM :: Okay (a -> b) => String -> Mealy a b -> IO ()
goM name = goM' name []
{-# INLINE goM #-}

goMSep :: Okay (a -> b) => String -> Double -> Mealy a b -> IO ()
goMSep name s = goM' name [ranksep s]
{-# INLINE goMSep #-}

goM' :: Okay (a -> b) => String -> [Attr] -> Mealy a b -> IO ()
{-# INLINE goM' #-}

goM' name attrs = go' name attrs . asFun

#endif