{-|
Module      : SDNamespace
Description : Defines the state @SDNamespace@ along with associated functions modifying and using this state.
Copyright   : Anthony Wang, 2021
License     : MIT
Maintainer  : anthony.y.wang.math@gmail.com

This module defines @SDNamespace@, a state which keeps track of the defined 
categories, functors and natural transformations.

The most important function in this module is 'handle_sdc', which takes
a 'SDCommand' and does the corresponding action, i.e.
adding it to the 'SDNamespace' state for define actions, and reading from
the 'SDNamespace' state and writing an output file for draw actions.
-}
{-# LANGUAGE RankNTypes #-}
module SDNamespace where

import Prelude hiding (Functor)
import Control.Monad (foldM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Strict (State, runState, get, put, modify)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT, maybeToExceptT)
import Control.Monad.Except (Except, ExceptT, mapExceptT, runExceptT, withExceptT, throwError, withExcept)
import Control.Applicative ((<$>),(<|>))
import Control.Lens.Type (Lens')
import Control.Lens.Getter (view)
import Control.Lens.Setter (set, over)
import Control.Lens.Combinators (lens)
import Control.Lens.Tuple (_1,_2,_3)
import qualified Data.Map.Strict as Map
import Data.Functor.Identity (runIdentity)
import Data.Maybe (isNothing, fromJust)
import Data.List (partition, intercalate)
import Data.Either (isLeft)
import System.IO (stderr, hPutStrLn)
import TwoCatOfCats
import SDParser
import Internal.FormattingData
import TikzObjects
import TikzStringDiagram

-- | A class for 'Category', 'Functor' and 'NaturalTransformation',
--  defining some functions useful for common handling of all three data structures.
--
--  Minimal complete definition : 'get_id', 'struct_str' and 'sdns_lens'.
class Structure a where
    get_id :: a -> String -- ^ gets an id string.
                          -- For functors it is defined for basic functors and identity functors.
                          -- For natural transformations, it is defined for basic natural
                          -- transformations, identity natural transformations of basic functors,
                          -- and identity natural transformations of identity functors of
                          -- categories.
    struct_str :: a->String -- ^ a string saying which type of structure the object is
    sdns_lens :: a -> Lens' SDNamespace (Namespace a) -- ^ A lens for getting the corresponding namespace in an 'SDNamespace'
    insertion_error_msg :: a -> String  -- ^ derived from 'get_id' and 'struct_str'
    insertion_error_msg a
s = String
"The "String -> String -> String
forall a. [a] -> [a] -> [a]
++(a -> String
forall a. Structure a => a -> String
struct_str a
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" id "String -> String -> String
forall a. [a] -> [a] -> [a]
++(a -> String
forall a. Structure a => a -> String
get_id a
s)
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" is already in the "String -> String -> String
forall a. [a] -> [a] -> [a]
++(a -> String
forall a. Structure a => a -> String
struct_str a
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" namespace. Skipping."
instance Structure Category where
    get_id :: Category -> String
get_id = Category -> String
cat_id
    struct_str :: Category -> String
struct_str Category
_ = String
"category"
    sdns_lens :: Category -> Lens' SDNamespace (Namespace Category)
sdns_lens Category
_ = (Namespace Category -> f (Namespace Category))
-> SDNamespace -> f SDNamespace
Lens' SDNamespace (Namespace Category)
category
instance Structure Functor where
    get_id :: Functor -> String
get_id Functor
f
        | Functor -> Bool
is_basic_func Functor
f = Functor -> String
func_id Functor
f
        | Functor -> Bool
is_identity_func Functor
f = Category -> String
forall a. Structure a => a -> String
get_id (Category -> String) -> Category -> String
forall a b. (a -> b) -> a -> b
$ Functor -> Category
func_source Functor
f
    get_id Functor
_ = String -> String
forall a. HasCallStack => String -> a
error String
"Error: get_id is not defined for the given functor."
    struct_str :: Functor -> String
struct_str Functor
_ = String
"functor"
    sdns_lens :: Functor -> Lens' SDNamespace (Namespace Functor)
sdns_lens Functor
_ = (Namespace Functor -> f (Namespace Functor))
-> SDNamespace -> f SDNamespace
Lens' SDNamespace (Namespace Functor)
functor
instance Structure NaturalTransformation where
    get_id :: NaturalTransformation -> String
get_id NaturalTransformation
nt 
        | NaturalTransformation -> Bool
is_basic_nt NaturalTransformation
nt = NaturalTransformation -> String
nt_id NaturalTransformation
nt
        | NaturalTransformation -> Bool
is_identity_nt NaturalTransformation
nt = Functor -> String
forall a. Structure a => a -> String
get_id (Functor -> String) -> Functor -> String
forall a b. (a -> b) -> a -> b
$ NaturalTransformation -> Functor
nat_source NaturalTransformation
nt
    get_id NaturalTransformation
_ = String -> String
forall a. HasCallStack => String -> a
error String
"Error: get_id is not defined for the given natural transformation."
    struct_str :: NaturalTransformation -> String
struct_str NaturalTransformation
_ = String
"natural transformation"
    sdns_lens :: NaturalTransformation
-> Lens' SDNamespace (Namespace NaturalTransformation)
sdns_lens NaturalTransformation
_ = (Namespace NaturalTransformation
 -> f (Namespace NaturalTransformation))
-> SDNamespace -> f SDNamespace
Lens' SDNamespace (Namespace NaturalTransformation)
nat_trans

-- | @(Namespace a)@ is a type synonym for a @Map@ from @String@ to @a@.
-- In our case @a@ is either 'Category', 'Functor' or 'NaturalTransformation',
-- and the map will map an id string to the corresponding defined structure.
type Namespace a = Map.Map String a

-- | 'SDNamespace' consists of a 3-tuple of 'Namespace's, one for 'Category', one for
-- 'Functor' and one for 'NaturalTransformation'.
--
-- All functors in the functor 'Namespace' are assumed to be basic functors.
-- All natural transformations in the natural transformation 'Namespace' are assumed to be
-- basic natural transformations.
type SDNamespace = (Namespace Category, Namespace Functor, Namespace NaturalTransformation)

-- | An 'SDNamespace' where all 'Namespace's are empty.
empty_sdns :: SDNamespace
empty_sdns :: SDNamespace
empty_sdns = (Namespace Category
forall k a. Map k a
Map.empty, Namespace Functor
forall k a. Map k a
Map.empty, Namespace NaturalTransformation
forall k a. Map k a
Map.empty)

-- | A lens from an 'SDNamespace' into the 'Namespace' of defined categories.
category :: Lens' SDNamespace (Namespace Category)
category :: (Namespace Category -> f (Namespace Category))
-> SDNamespace -> f SDNamespace
category = (Namespace Category -> f (Namespace Category))
-> SDNamespace -> f SDNamespace
forall s t a b. Field1 s t a b => Lens s t a b
_1

-- | A lens from an 'SDNamespace' into the 'Namespace' of defined functors.
functor :: Lens' SDNamespace (Namespace Functor)
functor :: (Namespace Functor -> f (Namespace Functor))
-> SDNamespace -> f SDNamespace
functor = (Namespace Functor -> f (Namespace Functor))
-> SDNamespace -> f SDNamespace
forall s t a b. Field2 s t a b => Lens s t a b
_2

-- | A lens from an 'SDNamespace' into the 'Namespace' of defined natural transformations.
nat_trans :: Lens' SDNamespace (Namespace NaturalTransformation)
nat_trans :: (Namespace NaturalTransformation
 -> f (Namespace NaturalTransformation))
-> SDNamespace -> f SDNamespace
nat_trans = (Namespace NaturalTransformation
 -> f (Namespace NaturalTransformation))
-> SDNamespace -> f SDNamespace
forall s t a b. Field3 s t a b => Lens s t a b
_3

-- | The obvious action: given a lens from an object of type @a@ to an object of type @b@
-- and a state action taking a state of type @b@ and outputting a new state of type @b@
-- along with an object of type @c@, we get a new state action by taking a state of type
-- @a@, using the lens to view this to get an object of type @b@, running the given state action
-- to get a new object of type @b@ and an object of type @c@, and finally, using the lens
-- to set this new object of type @b@ back into the original state of type @a@.
processing :: (Lens' a b) -> (State b c) -> (State a c)
processing :: Lens' a b -> State b c -> State a c
processing Lens' a b
lns State b c
st = do a
a_obj <- StateT a Identity a
forall s (m :: * -> *). MonadState s m => m s
get
                       let b_obj :: b
b_obj = Getting b a b -> a -> b
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting b a b
Lens' a b
lns a
a_obj
                       let (c
out,b
b_obj') = State b c -> b -> (c, b)
forall s a. State s a -> s -> (a, s)
runState State b c
st b
b_obj
                       a -> StateT a Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASetter a a b b -> b -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter a a b b
Lens' a b
lns b
b_obj' a
a_obj)
                       c -> State a c
forall (m :: * -> *) a. Monad m => a -> m a
return c
out

-- | Viewing the lens @get@ action as a state action which does not change the underlying state.
lens_get :: (Lens' a b) -> (State a b)
lens_get :: Lens' a b -> State a b
lens_get Lens' a b
lns = do a
a_obj <- StateT a Identity a
forall s (m :: * -> *). MonadState s m => m s
get
                  b -> State a b
forall (m :: * -> *) a. Monad m => a -> m a
return (Getting b a b -> a -> b
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting b a b
Lens' a b
lns a
a_obj)

-- | 'sdns_lookup' takes a @String@ and a lens from 'SDNamespace' into one of its component
-- 'Namespace's, and attempts to lookup the string in that namespace.
sdns_lookup :: (Structure a) => String -> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup :: String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
str Lens' SDNamespace (Namespace a)
lns = do Namespace a
ns <- StateT SDNamespace Identity (Namespace a)
-> MaybeT (State SDNamespace) (Namespace a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT SDNamespace Identity (Namespace a)
 -> MaybeT (State SDNamespace) (Namespace a))
-> StateT SDNamespace Identity (Namespace a)
-> MaybeT (State SDNamespace) (Namespace a)
forall a b. (a -> b) -> a -> b
$ Lens' SDNamespace (Namespace a)
-> StateT SDNamespace Identity (Namespace a)
forall a b. Lens' a b -> State a b
lens_get Lens' SDNamespace (Namespace a)
lns
                         State SDNamespace (Maybe a) -> MaybeT (State SDNamespace) a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (State SDNamespace (Maybe a) -> MaybeT (State SDNamespace) a)
-> State SDNamespace (Maybe a) -> MaybeT (State SDNamespace) a
forall a b. (a -> b) -> a -> b
$ Maybe a -> State SDNamespace (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Namespace a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
str Namespace a
ns)

-- | A helper function for 'insert_action'.
insert_action' :: (Structure a) => a -> State (Namespace a) (IO ())
insert_action' :: a -> State (Namespace a) (IO ())
insert_action' a
obj = do let key :: String
key = a -> String
forall a. Structure a => a -> String
get_id a
obj
                        Namespace a
curr_state <- StateT (Namespace a) Identity (Namespace a)
forall s (m :: * -> *). MonadState s m => m s
get
                        case String -> Namespace a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
key Namespace a
curr_state of 
                            Bool
True -> IO () -> State (Namespace a) (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State (Namespace a) (IO ()))
-> IO () -> State (Namespace a) (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Structure a => a -> String
insertion_error_msg a
obj
                            Bool
False -> (Namespace a -> Namespace a) -> StateT (Namespace a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (String -> a -> Namespace a -> Namespace a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
key a
obj) StateT (Namespace a) Identity ()
-> State (Namespace a) (IO ()) -> State (Namespace a) (IO ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> State (Namespace a) (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ());

-- | @(insert_action obj)@ is the @State (SDNamespace a) (IO ())@
--  which adds the key value pair @(get_id obj, obj)@ to the correct namespace if
--  @(get_id obj)@ is not already a key in the namespace, 
--  and gives the IO action printing an error message to stderr otherwise.
insert_action :: (Structure a) => a -> State SDNamespace (IO ())
insert_action :: a -> State SDNamespace (IO ())
insert_action a
s = Lens' SDNamespace (Namespace a)
-> State (Namespace a) (IO ()) -> State SDNamespace (IO ())
forall a b c. Lens' a b -> State b c -> State a c
processing (a -> Lens' SDNamespace (Namespace a)
forall a. Structure a => a -> Lens' SDNamespace (Namespace a)
sdns_lens a
s) (a -> State (Namespace a) (IO ())
forall a. Structure a => a -> State (Namespace a) (IO ())
insert_action' a
s)

-- | A partial function on 'SDCommand's which were constructed using 'DefineCat'.
-- See 'handle_sdc'.
handle_def_cat :: SDCommand -> State SDNamespace (IO ())
handle_def_cat :: SDCommand -> State SDNamespace (IO ())
handle_def_cat (DefineCat String
cid String
ds) = Category -> State SDNamespace (IO ())
forall a. Structure a => a -> State SDNamespace (IO ())
insert_action (String -> String -> Category
Category String
cid String
ds)
handle_def_cat SDCommand
_ = String -> State SDNamespace (IO ())
forall a. HasCallStack => String -> a
error (String -> State SDNamespace (IO ()))
-> String -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ String
"Error! handle_def_cat should only be called by handle_sdc,"
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" which should only call handle_def_cat when handling"
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" DefineCat SDCommands"

-- | A partial function on 'SDCommand's which were constructed using 'DefineFunc'.
-- See 'handle_sdc'.
handle_def_fun :: SDCommand -> State SDNamespace (IO ())
handle_def_fun :: SDCommand -> State SDNamespace (IO ())
handle_def_fun (DefineFunc String
f_id String
ds String
source_id String
target_id String
opts) = 
    do Maybe Category
source <- MaybeT (State SDNamespace) Category
-> State SDNamespace (Maybe Category)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (State SDNamespace) Category
 -> State SDNamespace (Maybe Category))
-> MaybeT (State SDNamespace) Category
-> State SDNamespace (Maybe Category)
forall a b. (a -> b) -> a -> b
$ String
-> Lens' SDNamespace (Namespace Category)
-> MaybeT (State SDNamespace) Category
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
source_id Lens' SDNamespace (Namespace Category)
category
       Maybe Category
target <- MaybeT (State SDNamespace) Category
-> State SDNamespace (Maybe Category)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (State SDNamespace) Category
 -> State SDNamespace (Maybe Category))
-> MaybeT (State SDNamespace) Category
-> State SDNamespace (Maybe Category)
forall a b. (a -> b) -> a -> b
$ String
-> Lens' SDNamespace (Namespace Category)
-> MaybeT (State SDNamespace) Category
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
target_id Lens' SDNamespace (Namespace Category)
category
       case (Maybe Category
source, Maybe Category
target) of 
            (Maybe Category
Nothing, Maybe Category
Nothing) -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
source_not_found_error) 
                                            IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
target_not_found_error)
            (Maybe Category
Nothing, Maybe Category
_)       -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
source_not_found_error 
            (Maybe Category
_, Maybe Category
Nothing)       -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
target_not_found_error
            (Just Category
s, Just Category
t)   -> Functor -> State SDNamespace (IO ())
forall a. Structure a => a -> State SDNamespace (IO ())
insert_action (Functor -> State SDNamespace (IO ()))
-> Functor -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ String -> String -> ZeroGlobelet -> String -> Functor
Functor String
f_id String
ds (Category -> Category -> ZeroGlobelet
ZeroGlobelet Category
s Category
t) String
opts
    where 
        source_not_found_error :: String
source_not_found_error = String
"The category " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
source_id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" could not be found.\n\t"
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"When giving the source in the definition of the functor "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
f_id
        target_not_found_error :: String
target_not_found_error = String
"The category " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
target_id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" could not be found.\n\t"
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"When giving the target in the definition of the functor "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
f_id
handle_def_fun SDCommand
_ = String -> State SDNamespace (IO ())
forall a. HasCallStack => String -> a
error (String -> State SDNamespace (IO ()))
-> String -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ String
"Error! handle_def_fun should only be called by handle_sdc,"
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" which should only call handle_def_fun when handling"
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" DefineFunc SDCommands"

-- | A partial function on 'SDCommand's which were constructed using 'DefineNat'.
-- See 'handle_sdc'.
handle_def_nat :: SDCommand -> State SDNamespace (IO ())
handle_def_nat :: SDCommand -> State SDNamespace (IO ())
handle_def_nat (DefineNat String
ntid String
ds [CompElement]
source [CompElement]
target String
opts String
shape) =
    do Either FunctorReadError (Functor, FunctorFormatting)
source_f <- ExceptT
  FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> State
     SDNamespace (Either FunctorReadError (Functor, FunctorFormatting))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
 -> State
      SDNamespace (Either FunctorReadError (Functor, FunctorFormatting)))
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> State
     SDNamespace (Either FunctorReadError (Functor, FunctorFormatting))
forall a b. (a -> b) -> a -> b
$ [CompElement]
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
read_functor_line [CompElement]
source
       Either FunctorReadError (Functor, FunctorFormatting)
target_f <- ExceptT
  FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> State
     SDNamespace (Either FunctorReadError (Functor, FunctorFormatting))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
 -> State
      SDNamespace (Either FunctorReadError (Functor, FunctorFormatting)))
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> State
     SDNamespace (Either FunctorReadError (Functor, FunctorFormatting))
forall a b. (a -> b) -> a -> b
$ [CompElement]
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
read_functor_line [CompElement]
target
       case (Either FunctorReadError (Functor, FunctorFormatting)
source_f, Either FunctorReadError (Functor, FunctorFormatting)
target_f) of 
            (Left FunctorReadError
err, Either FunctorReadError (Functor, FunctorFormatting)
_) -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ FunctorReadError -> String
forall a. Error a => a -> String
error_msg FunctorReadError
err
                                         Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\tWhen describing the source in the definition of "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ntid
            (Either FunctorReadError (Functor, FunctorFormatting)
_, Left FunctorReadError
err)     -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ FunctorReadError -> String
forall a. Error a => a -> String
error_msg FunctorReadError
err
                                             Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\tWhen describing the target in the definition of "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ntid
            (Right (Functor
s,FunctorFormatting
_), Right (Functor
t,FunctorFormatting
_)) -> case (Functor -> Bool
is_identity_func Functor
s) Bool -> Bool -> Bool
&& (Functor -> Bool
is_identity_func Functor
t) of
                Bool
True -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
source_target_identity_error
                Bool
False -> let bg :: Maybe OneGlobelet
bg = Functor -> Functor -> Maybe OneGlobelet
funcs_to_globelet Functor
s Functor
t in
                    case Maybe OneGlobelet
bg of Maybe OneGlobelet
Nothing -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
boundary_not_globelet_error
                               Just OneGlobelet
b  -> NaturalTransformation -> State SDNamespace (IO ())
forall a. Structure a => a -> State SDNamespace (IO ())
insert_action (NaturalTransformation -> State SDNamespace (IO ()))
-> NaturalTransformation -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ String
-> String
-> String
-> OneGlobelet
-> String
-> NaturalTransformation
NaturalTransformation String
ntid String
ds String
shape OneGlobelet
b String
opts
    where
        boundary_not_globelet_error :: String
boundary_not_globelet_error 
            = String
"The source and target in the definition of the natural transformation "
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ntid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" do not have the same source/target."
        source_target_identity_error :: String
source_target_identity_error 
            = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Currently, creating a natural transformation "
                     ,String
"whose source and target are both identity functors is not supported, "
                     ,String
"as this will result in a TikZ node for the natural transformation "
                     ,String
"with no in strings and no out strings. "
                     ,String
"\nExplicitly define an identity functor instead, "
                     ,String
"so that there is an in string and an out string"]
handle_def_nat SDCommand
_ 
    = String -> State SDNamespace (IO ())
forall a. HasCallStack => String -> a
error (String -> State SDNamespace (IO ()))
-> String -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ String
"Error! handle_def_nat should only be called by handle_sdc,"
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" which should only call handle_def_nat when handling"
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" DefineNat SDCommands"

-- | A lens from a 'Category' to its string of options.
cat_opt_lens :: Lens' Category String
cat_opt_lens :: (String -> f String) -> Category -> f Category
cat_opt_lens = (Category -> String)
-> (Category -> String -> Category)
-> Lens Category Category String String
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (String -> Category -> String
forall a b. a -> b -> a
const String
"") Category -> String -> Category
forall a b. a -> b -> a
const

-- | A lens from a 'Functor' to its string of options.
func_opt_lens :: Lens' Functor String
func_opt_lens :: (String -> f String) -> Functor -> f Functor
func_opt_lens = (Functor -> String)
-> (Functor -> String -> Functor)
-> Lens Functor Functor String String
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Functor -> String
get_opts Functor -> String -> Functor
change_opts
    where
        get_opts :: Functor -> String
get_opts (Functor String
_i String
_d ZeroGlobelet
_b String
o) = String
o
        get_opts Functor
_ = String -> String
forall a. HasCallStack => String -> a
error String
"currently can only get options of a basic functor"
        change_opts :: Functor -> String -> Functor
change_opts (Functor String
i String
d ZeroGlobelet
b String
_o) String
new_o = String -> String -> ZeroGlobelet -> String -> Functor
Functor String
i String
d ZeroGlobelet
b String
new_o
        change_opts Functor
_ String
_ = String -> Functor
forall a. HasCallStack => String -> a
error String
"currently can only change options of a basic functor"

-- | A lens from a 'NaturalTransformation' to its string of options.
nat_opt_lens :: Lens' NaturalTransformation String
nat_opt_lens :: (String -> f String)
-> NaturalTransformation -> f NaturalTransformation
nat_opt_lens = (NaturalTransformation -> String)
-> (NaturalTransformation -> String -> NaturalTransformation)
-> Lens NaturalTransformation NaturalTransformation String String
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens NaturalTransformation -> String
get_opts NaturalTransformation -> String -> NaturalTransformation
change_opts
    where
        get_opts :: NaturalTransformation -> String
get_opts (NaturalTransformation String
_i String
_d String
_s OneGlobelet
_b String
o) = String
o
        get_opts NaturalTransformation
_ = String -> String
forall a. HasCallStack => String -> a
error String
"currently can only get options of a basic natural transformation"
        change_opts :: NaturalTransformation -> String -> NaturalTransformation
change_opts (NaturalTransformation String
i String
d String
s OneGlobelet
b String
_o) String
new_o = String
-> String
-> String
-> OneGlobelet
-> String
-> NaturalTransformation
NaturalTransformation String
i String
d String
s OneGlobelet
b String
new_o
        change_opts NaturalTransformation
_ String
_ = String -> NaturalTransformation
forall a. HasCallStack => String -> a
error String
"currently can only change options of a basic natural transformation"

-- | @(sdns_lookup_add str lns1 added lns2)@ looks up @str@ from the 'Namespace' extracted using @lns1@ 
-- from the 'SDNamespace', then modifies the
--looked-up object @o@ by adding @","++added@ to the end of @lns2@ of the object @o@.
sdns_lookup_add :: (Structure a)=> String -> Lens' SDNamespace (Namespace a)-> String -> Lens' a String 
    -> MaybeT (State SDNamespace) a
sdns_lookup_add :: String
-> Lens' SDNamespace (Namespace a)
-> String
-> Lens' a String
-> MaybeT (State SDNamespace) a
sdns_lookup_add String
str Lens' SDNamespace (Namespace a)
lns1 String
"" Lens' a String
_ = String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
str Lens' SDNamespace (Namespace a)
lns1
sdns_lookup_add String
str Lens' SDNamespace (Namespace a)
lns1 String
added Lens' a String
lns2 
    = do a
obj <- String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
str Lens' SDNamespace (Namespace a)
lns1
         a -> MaybeT (State SDNamespace) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> MaybeT (State SDNamespace) a)
-> a -> MaybeT (State SDNamespace) a
forall a b. (a -> b) -> a -> b
$ (ASetter a a String String -> (String -> String) -> a -> a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter a a String String
Lens' a String
lns2 (String -> String -> String
forall a. Monoid a => a -> a -> a
`mappend` (Char
','Char -> String -> String
forall a. a -> [a] -> [a]
:String
added))) a
obj

-- | @(sdns_chain_lookup_func id opt)@ attempts to lookup the @id@ in the functor
-- @Namespace@ and adds the options @opt@ to the options of the looked up functor.
-- If it cannot find @id@ in the functor namespace, it looks up @id@ in the category 'Namespace' and returns
-- the identity functor of the resulting category.
sdns_chain_lookup_func :: String -> String -> MaybeT (State SDNamespace) Functor
sdns_chain_lookup_func :: String -> String -> MaybeT (State SDNamespace) Functor
sdns_chain_lookup_func String
eid String
opt 
    = String
-> Lens' SDNamespace (Namespace Functor)
-> String
-> Lens Functor Functor String String
-> MaybeT (State SDNamespace) Functor
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a)
-> String
-> Lens' a String
-> MaybeT (State SDNamespace) a
sdns_lookup_add String
eid Lens' SDNamespace (Namespace Functor)
functor String
opt Lens Functor Functor String String
func_opt_lens 
      MaybeT (State SDNamespace) Functor
-> MaybeT (State SDNamespace) Functor
-> MaybeT (State SDNamespace) Functor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Category -> Functor
identityFunctor (Category -> Functor)
-> MaybeT (State SDNamespace) Category
-> MaybeT (State SDNamespace) Functor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Lens' SDNamespace (Namespace Category)
-> MaybeT (State SDNamespace) Category
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
eid Lens' SDNamespace (Namespace Category)
category)

-- | @(sdns_chain_lookup_nat id opt)@ attemps to lookup the @id@ in the natural transformation
-- @Namespace@ and adds the options @opt@ to the options of the looked up natural transformation.
-- If it cannot find @id@ in the natural transformation namespace, it looks up @id@ in the
-- functor namespace, and returns the identity natural transformation of the functor if it finds it
-- there.
-- If it cannot find @id@ in either the natural transformation or functor namespaces, it looks up
-- @id@ in the category namespace, and returns the identity natural transformation of the identity
-- functor of the category if it finds it there.
sdns_chain_lookup_nat :: String -> String -> MaybeT (State SDNamespace) NaturalTransformation
sdns_chain_lookup_nat :: String
-> String -> MaybeT (State SDNamespace) NaturalTransformation
sdns_chain_lookup_nat String
eid String
opt 
    =  String
-> Lens' SDNamespace (Namespace NaturalTransformation)
-> String
-> Lens NaturalTransformation NaturalTransformation String String
-> MaybeT (State SDNamespace) NaturalTransformation
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a)
-> String
-> Lens' a String
-> MaybeT (State SDNamespace) a
sdns_lookup_add String
eid Lens' SDNamespace (Namespace NaturalTransformation)
nat_trans String
opt Lens NaturalTransformation NaturalTransformation String String
nat_opt_lens 
       MaybeT (State SDNamespace) NaturalTransformation
-> MaybeT (State SDNamespace) NaturalTransformation
-> MaybeT (State SDNamespace) NaturalTransformation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Functor -> NaturalTransformation
identityNaturalTransformation (Functor -> NaturalTransformation)
-> MaybeT (State SDNamespace) Functor
-> MaybeT (State SDNamespace) NaturalTransformation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Lens' SDNamespace (Namespace Functor)
-> MaybeT (State SDNamespace) Functor
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
eid Lens' SDNamespace (Namespace Functor)
functor)
       MaybeT (State SDNamespace) NaturalTransformation
-> MaybeT (State SDNamespace) NaturalTransformation
-> MaybeT (State SDNamespace) NaturalTransformation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Functor -> NaturalTransformation
identityNaturalTransformation (Functor -> NaturalTransformation)
-> (Category -> Functor) -> Category -> NaturalTransformation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Category -> Functor
identityFunctor (Category -> NaturalTransformation)
-> MaybeT (State SDNamespace) Category
-> MaybeT (State SDNamespace) NaturalTransformation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Lens' SDNamespace (Namespace Category)
-> MaybeT (State SDNamespace) Category
forall a.
Structure a =>
String
-> Lens' SDNamespace (Namespace a) -> MaybeT (State SDNamespace) a
sdns_lookup String
eid Lens' SDNamespace (Namespace Category)
category)

-- | A class for errors which have error messages.
class Error a where
    error_msg :: a->String

-- | 'FunctorReadError' is the type of error that can be thrown by 'read_functor_line'.
-- Either some of the functors in the lookup do no exist,
--  or the list of functors do not compose.
--
-- 'LookupFunctorError' @list@ says that there are functors which cannot be found
-- in the 'SDNamespace'.
-- Here @list@ is a list of pairs @(n,id)@ where @n@ is the position in the functor line
-- where the given @id@ cannot be found.
--
-- 'ComposeFunctorError' @list@ says that the composition could not be determined.
-- Here, @list@ is empty if the functor line has no functors, i.e. it specifies an empty
-- composition.
-- Otherwise, it is a list of 4-tuples @(n1,id1,n2,id2)@ where @n1@ is the position of @id1@
-- and @n2@ is the position of @id2@, and the functors specified by @id1@ and @id2@ do not compose.
data FunctorReadError = LookupFunctorError [(Int,String)] 
                      | ComposeFunctorError [(Int,String,Int,String)] 

instance Error FunctorReadError where
    error_msg :: FunctorReadError -> String
error_msg (LookupFunctorError [(Int, String)]
places) 
        = String
"The id(s) " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
lfe_msg_helper [(Int, String)]
places)
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" could not be found in either the"
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" functor or category namespaces."
    error_msg (ComposeFunctorError []) 
        = String
"Cannot form a composition of an empty list of functors. "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"Categories can be used to denote their identity functors."
    error_msg (ComposeFunctorError [(Int, String, Int, String)]
places) 
        = String
"The functors " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, String, Int, String) -> String)
-> [(Int, String, Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String, Int, String) -> String
cfe_msg_helper [(Int, String, Int, String)]
places)
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" cannot be composed."

-- | A helper function used to define 'error_msg' of a 'LookupFunctorError'
lfe_msg_helper :: (Int,String) -> String
lfe_msg_helper :: (Int, String) -> String
lfe_msg_helper (Int
n, String
str) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
str,String
" in position ", Int -> String
forall a. Show a => a -> String
show Int
n]

-- | A helper function used to define 'error_msg' of a 'ComposeFunctorError'
cfe_msg_helper :: (Int,String,Int,String) -> String
cfe_msg_helper :: (Int, String, Int, String) -> String
cfe_msg_helper (Int
n1, String
str1, Int
n2, String
str2) 
    = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
str1, String
" at position ", Int -> String
forall a. Show a => a -> String
show Int
n1, String
" and ", String
str2, String
" at position ", Int -> String
forall a. Show a => a -> String
show Int
n2]

-- | 'read_functor_line' takes a list of 'CompElement's representing a collection of functors or empty
-- spaces, either throws a 'FunctorReadError' or returns a pair @(f,ff)@ where @f@ is the composite 'Functor' and
-- @ff@ is the 'FunctorFormatting' associated to @f@ described by the spacing in the original list of
-- @CompElement@s.
-- See the user's manual for how @ff@ and @f@ are determined.
read_functor_line :: [CompElement] -> ExceptT FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
read_functor_line :: [CompElement]
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
read_functor_line [CompElement]
list 
    = do [(Int, String, Functor)]
items <- [CompElement]
-> ExceptT
     FunctorReadError (State SDNamespace) [(Int, String, Functor)]
list_ce_to_funcs [CompElement]
list
         (Functor
c,[Int]
l) <- (Identity (Either FunctorReadError (Functor, [Int]))
 -> State SDNamespace (Either FunctorReadError (Functor, [Int])))
-> ExceptT FunctorReadError Identity (Functor, [Int])
-> ExceptT FunctorReadError (State SDNamespace) (Functor, [Int])
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (Either FunctorReadError (Functor, [Int])
-> State SDNamespace (Either FunctorReadError (Functor, [Int]))
forall (m :: * -> *) a. Monad m => a -> m a
return(Either FunctorReadError (Functor, [Int])
 -> State SDNamespace (Either FunctorReadError (Functor, [Int])))
-> (Identity (Either FunctorReadError (Functor, [Int]))
    -> Either FunctorReadError (Functor, [Int]))
-> Identity (Either FunctorReadError (Functor, [Int]))
-> State SDNamespace (Either FunctorReadError (Functor, [Int]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Identity (Either FunctorReadError (Functor, [Int]))
-> Either FunctorReadError (Functor, [Int])
forall a. Identity a -> a
runIdentity) (ExceptT FunctorReadError Identity (Functor, [Int])
 -> ExceptT FunctorReadError (State SDNamespace) (Functor, [Int]))
-> ExceptT FunctorReadError Identity (Functor, [Int])
-> ExceptT FunctorReadError (State SDNamespace) (Functor, [Int])
forall a b. (a -> b) -> a -> b
$ [(Int, String, Functor)]
-> ExceptT FunctorReadError Identity (Functor, [Int])
compose_funcs [(Int, String, Functor)]
items
         (Functor, FunctorFormatting)
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
forall (m :: * -> *) a. Monad m => a -> m a
return (Functor
c, Int -> [Int] -> FunctorFormatting
FunctorFormatting ([CompElement] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CompElement]
list) [Int]
l)

-- | 'list_ce_to_funcs' is used in 'read_functor_line'.
-- It takes a list of 'CompElement's
-- either throws a 'LookupFunctorError' or gives a list of @(n,id,f)@ for each
-- non-@Empty@ 'CompElement' in the list,
-- where @n@ is the index in the original list the non-@Empty@ 'CompElement' resides
--      (with indexing starting at @0@), 
--  @id@ is the @id@ of the functor,
--  and @f@ is the functor from the 'SDNamespace' corresponding to the 'CompElement'.
list_ce_to_funcs :: [CompElement] -> ExceptT FunctorReadError (State SDNamespace) [(Int, String, Functor)]
list_ce_to_funcs :: [CompElement]
-> ExceptT
     FunctorReadError (State SDNamespace) [(Int, String, Functor)]
list_ce_to_funcs [CompElement]
list 
    = let list_with_pos :: [(Int, CompElement)]
list_with_pos = [Int] -> [CompElement] -> [(Int, CompElement)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [CompElement]
list
          ([Int]
posits, [CompElement]
list_ne) = [(Int, CompElement)] -> ([Int], [CompElement])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Int, CompElement)] -> ([Int], [CompElement]))
-> [(Int, CompElement)] -> ([Int], [CompElement])
forall a b. (a -> b) -> a -> b
$ ((Int, CompElement) -> Bool)
-> [(Int, CompElement)] -> [(Int, CompElement)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_x,CompElement
_y) -> CompElement
_y CompElement -> CompElement -> Bool
forall a. Eq a => a -> a -> Bool
/= CompElement
SDParser.Empty) [(Int, CompElement)]
list_with_pos
          ids :: [String]
ids = (CompElement -> String) -> [CompElement] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CompElement -> String
ce_id [CompElement]
list_ne
      in do [Maybe Functor]
funcs <- State SDNamespace [Maybe Functor]
-> ExceptT FunctorReadError (State SDNamespace) [Maybe Functor]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State SDNamespace [Maybe Functor]
 -> ExceptT FunctorReadError (State SDNamespace) [Maybe Functor])
-> State SDNamespace [Maybe Functor]
-> ExceptT FunctorReadError (State SDNamespace) [Maybe Functor]
forall a b. (a -> b) -> a -> b
$ (CompElement -> State SDNamespace (Maybe Functor))
-> [CompElement] -> State SDNamespace [Maybe Functor]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(CompElement String
cid String
opts) -> MaybeT (State SDNamespace) Functor
-> State SDNamespace (Maybe Functor)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (State SDNamespace) Functor
 -> State SDNamespace (Maybe Functor))
-> MaybeT (State SDNamespace) Functor
-> State SDNamespace (Maybe Functor)
forall a b. (a -> b) -> a -> b
$ String -> String -> MaybeT (State SDNamespace) Functor
sdns_chain_lookup_func String
cid String
opts) [CompElement]
list_ne
            let list_with_pos_id :: [(Int, String, Maybe Functor)]
list_with_pos_id = [Int]
-> [String] -> [Maybe Functor] -> [(Int, String, Maybe Functor)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
posits [String]
ids [Maybe Functor]
funcs
            let ([(Int, String, Maybe Functor)]
lookup_errors,[(Int, String, Maybe Functor)]
lookup_good) = ((Int, String, Maybe Functor) -> Bool)
-> [(Int, String, Maybe Functor)]
-> ([(Int, String, Maybe Functor)], [(Int, String, Maybe Functor)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Int
_x,String
_y,Maybe Functor
_z) -> Maybe Functor -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Functor
_z) [(Int, String, Maybe Functor)]
list_with_pos_id
            if [(Int, String, Maybe Functor)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, String, Maybe Functor)]
lookup_errors 
            then [(Int, String, Functor)]
-> ExceptT
     FunctorReadError (State SDNamespace) [(Int, String, Functor)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, String, Functor)]
 -> ExceptT
      FunctorReadError (State SDNamespace) [(Int, String, Functor)])
-> [(Int, String, Functor)]
-> ExceptT
     FunctorReadError (State SDNamespace) [(Int, String, Functor)]
forall a b. (a -> b) -> a -> b
$ ((Int, String, Maybe Functor) -> (Int, String, Functor))
-> [(Int, String, Maybe Functor)] -> [(Int, String, Functor)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
x,String
y,Just Functor
z) -> (Int
x,String
y,Functor
z)) [(Int, String, Maybe Functor)]
lookup_good
            else FunctorReadError
-> ExceptT
     FunctorReadError (State SDNamespace) [(Int, String, Functor)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FunctorReadError
 -> ExceptT
      FunctorReadError (State SDNamespace) [(Int, String, Functor)])
-> FunctorReadError
-> ExceptT
     FunctorReadError (State SDNamespace) [(Int, String, Functor)]
forall a b. (a -> b) -> a -> b
$ [(Int, String)] -> FunctorReadError
LookupFunctorError ([(Int, String)] -> FunctorReadError)
-> [(Int, String)] -> FunctorReadError
forall a b. (a -> b) -> a -> b
$ ((Int, String, Maybe Functor) -> (Int, String))
-> [(Int, String, Maybe Functor)] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
_x,String
_y,Maybe Functor
_z)-> (Int
_x,String
_y)) [(Int, String, Maybe Functor)]
lookup_errors

-- | 'compose_funcs' is used in 'read_functor_line'.
-- It takes an object of type @[(Int,String,Functor)]@ which is outputted by 'list_ce_to_funcs',
-- and attempts to compose the functors in the list.
-- It either throws a 'ComposeFunctorError' or gives a pair @(f,l)@
-- where @f@ is the composite functor
-- and @l@ is the list of the positions of the non-identity functors in the original list.
--
-- Here all the functors in the original list are assumed to either be of the form @(Functor i d b o)@
-- or be an identity functor.
compose_funcs::[(Int,String,Functor)] -> Except FunctorReadError (Functor,[Int])
compose_funcs :: [(Int, String, Functor)]
-> ExceptT FunctorReadError Identity (Functor, [Int])
compose_funcs [(Int, String, Functor)]
list 
    = do Functor
comp <- (FuncCompositionError -> FunctorReadError)
-> Except FuncCompositionError Functor
-> Except FunctorReadError Functor
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept FuncCompositionError -> FunctorReadError
mExcept (Except FuncCompositionError Functor
 -> Except FunctorReadError Functor)
-> Except FuncCompositionError Functor
-> Except FunctorReadError Functor
forall a b. (a -> b) -> a -> b
$ [Functor] -> Except FuncCompositionError Functor
func_compose_with_error ([Functor] -> Except FuncCompositionError Functor)
-> [Functor] -> Except FuncCompositionError Functor
forall a b. (a -> b) -> a -> b
$ ((Int, String, Functor) -> Functor)
-> [(Int, String, Functor)] -> [Functor]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Functor (Int, String, Functor) Functor
-> (Int, String, Functor) -> Functor
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Functor (Int, String, Functor) Functor
forall s t a b. Field3 s t a b => Lens s t a b
_3) [(Int, String, Functor)]
list
         (Functor, [Int])
-> ExceptT FunctorReadError Identity (Functor, [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (Functor
comp, ((Int, String, Functor) -> Int)
-> [(Int, String, Functor)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Int (Int, String, Functor) Int
-> (Int, String, Functor) -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int (Int, String, Functor) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1) ([(Int, String, Functor)] -> [Int])
-> [(Int, String, Functor)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, String, Functor) -> Bool)
-> [(Int, String, Functor)] -> [(Int, String, Functor)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> ((Int, String, Functor) -> Bool)
-> (Int, String, Functor)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Functor -> Bool
is_identity_func(Functor -> Bool)
-> ((Int, String, Functor) -> Functor)
-> (Int, String, Functor)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Getting Functor (Int, String, Functor) Functor
-> (Int, String, Functor) -> Functor
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Functor (Int, String, Functor) Functor
forall s t a b. Field3 s t a b => Lens s t a b
_3)) [(Int, String, Functor)]
list)
    where
        mExcept :: FuncCompositionError -> FunctorReadError
mExcept (FuncCompositionError [Int]
errs) 
            = let lefts :: [(Int, String, Functor)]
lefts = (Int -> (Int, String, Functor))
-> [Int] -> [(Int, String, Functor)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x-> [(Int, String, Functor)]
list [(Int, String, Functor)] -> Int -> (Int, String, Functor)
forall a. [a] -> Int -> a
!! Int
x) [Int]
errs
                  rights :: [(Int, String, Functor)]
rights = (Int -> (Int, String, Functor))
-> [Int] -> [(Int, String, Functor)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x-> [(Int, String, Functor)]
list [(Int, String, Functor)] -> Int -> (Int, String, Functor)
forall a. [a] -> Int -> a
!! (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) [Int]
errs
              in [(Int, String, Int, String)] -> FunctorReadError
ComposeFunctorError ([(Int, String, Int, String)] -> FunctorReadError)
-> [(Int, String, Int, String)] -> FunctorReadError
forall a b. (a -> b) -> a -> b
$ ((Int, String, Functor)
 -> (Int, String, Functor) -> (Int, String, Int, String))
-> [(Int, String, Functor)]
-> [(Int, String, Functor)]
-> [(Int, String, Int, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Int
x,String
y,Functor
_z)-> (\(Int
a,String
b,Functor
_c)-> (Int
x, String
y, Int
a, String
b))) [(Int, String, Functor)]
lefts [(Int, String, Functor)]
rights

-- | 'NatTransReadError' is the type of error which can be thrown by 'read_nat_trans'.
--
-- - @(LookupNatTransError m list)@ is an error thrown when reading a line representing a horizontal
-- composition of basic natural transformations and identity natural transformations. 
-- It says that some id could not be found in the
-- 'SDNamespace'. 
-- The number @m@ is the line number where the error occurs
-- is a list of pairs @(n,id)@ where @n@ is the position in the line where @id@
-- could not be found in the 'SDNamespace'.
--
-- - @(ImputationError m n)@ is an error thrown when imputing identity natural transformations on line @m@.
-- It says that the natural transformation in position @n@ on this line could not be imputed due
-- to the target functor of the previously specified lines is not the composition of enough basic functors.
--
-- - @(HorzComposeNatTransError m list)@ is an error thrown when reading a line representing a
-- horizontal composition of basic natural transformations and identity natural transformations.
-- It says that the looked up functors could not be horizontally composed.
-- The number @m@ is the line number where the error occurs, and
-- @list@ is a list of 4-tuples @(n1,str1,n2,str2)@, where 
--  @n1@ is the position in the line of @id1@ and @n2@ is the position in the line of @id2@
--  and the natural transformations specified by @id1@ and @id2@ cannot be horizontally composed.
-- An empty list corresponding to an empty composition.
--
-- - @NoLinesError@ is an error which is thrown when there are no lines when specifying the
-- natural transformation.
--
-- - @FirstLineImputationError@ is an error which is thrown when the first line in the specification
-- of a natural transformation contains empty places, meaning that these places cannot be imputed.
--
-- - @(FRE m fre)@ is an error which is thrown when line @m@ is a line specifying a functor,
-- and @fre@ is a 'FunctorReadError' thrown when reading this line.
--
-- - @(TwoConsecutiveFunctorsError m)@ says that line @m-1@ and line @m@ are both used to specify a 
-- functor.
--
-- - @(IncompatibleLinesError m)@ says that line @m@ is incompatible with the previously specified
-- lines.
-- If line @m@ is a line specifying a functor, this means that the target of the natural
-- transformation specified by the previous line is not equal to the functor specfied by line @m@.
-- If line @m@ is a line specifying a natural transformation, it says that the target of the natural
-- transformation specified by the previous lines is not equal to the source of the natural
-- transformation specified by line @m@.
data NatTransReadError = LookupNatTransError Int [(Int, String)]
                       | ImputationError Int Int
                       | HorzComposeNatTransError Int [(Int,String,Int,String)]
                       | NoLinesError
                       | FirstLineImputationError
                       | FRE Int FunctorReadError
                       | TwoConsecutiveFunctorsError Int
                       | IncompatibleLinesError Int

instance Error NatTransReadError where
    error_msg :: NatTransReadError -> String
error_msg (LookupNatTransError Int
line [(Int, String)]
places) 
        = String
"On line "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
line)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" the id(s) "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++(String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
lnte_msg_helper [(Int, String)]
places) 
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" could not be found in the natural transformation, "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"functor or category namespaces."
    error_msg (ImputationError Int
line Int
position) 
        = String
"On line "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
line)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
", position "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
position)String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" could not be imputed: "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"the target functor of the previous lines"
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" does not have enough basic functors."
    error_msg (HorzComposeNatTransError Int
line []) 
        = String
"On line "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
line)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
", cannot form an empty horizontal composition "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"of natural transformations."
        -- in the current iteration of the program, I don't think this will ever be matched, as
        -- every parsed SDDrawNat line should be a list of length at least 1.
    error_msg (HorzComposeNatTransError Int
line [(Int, String, Int, String)]
places) 
        = String
"On line "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
line)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
", the natural transformations " 
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, String, Int, String) -> String)
-> [(Int, String, Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String, Int, String) -> String
hcnte_msg_helper [(Int, String, Int, String)]
places)
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" cannot be horizontally composed."
    error_msg NatTransReadError
NoLinesError 
        = String
"Error: empty natural transformation."
    error_msg NatTransReadError
FirstLineImputationError 
        = String
"Cannot impute functors on in a natural transformation without specifying a source."
    error_msg (FRE Int
line FunctorReadError
fre) 
        = String
"On line "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
line)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
": "String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctorReadError -> String
forall a. Error a => a -> String
error_msg FunctorReadError
fre
    error_msg (TwoConsecutiveFunctorsError Int
line) 
        = String
"Error: two consecutive functor lines "String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
lineInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
line) 
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"in the specification of a natural transformation."
    error_msg (IncompatibleLinesError Int
line) 
        = String
"Line "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String
forall a. Show a => a -> String
show Int
line)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" is incompatible with the previously specified lines."

-- | A helper function in defining 'error_msg' of a 'LookupNatTransError'.
lnte_msg_helper :: (Int,String) -> String
lnte_msg_helper :: (Int, String) -> String
lnte_msg_helper = (Int, String) -> String
lfe_msg_helper

-- | A helper function in defining 'error_msg' of a 'HorzComposeNatTransError'.
hcnte_msg_helper :: (Int, String, Int, String) -> String
hcnte_msg_helper :: (Int, String, Int, String) -> String
hcnte_msg_helper = (Int, String, Int, String) -> String
cfe_msg_helper

-- | 'list_ce_to_nt' takes a list of 'CompElement's representing natural transformations
--and the current line number
--and either throws a 'LookupNatTransError' or returns a list of @Maybe NaturalTransformation@
--gotten by mapping @Empty@ to @Nothing@
--and @(CompElement id opts)@ to @Just@ the corresponding natural transformation from 'SDNamespace'.
list_ce_to_nt :: [CompElement] -> Int -> ExceptT NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
list_ce_to_nt :: [CompElement]
-> Int
-> ExceptT
     NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
list_ce_to_nt [CompElement]
list Int
m 
    = do [Either String (Maybe NaturalTransformation)]
found_list <- State SDNamespace [Either String (Maybe NaturalTransformation)]
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     [Either String (Maybe NaturalTransformation)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State SDNamespace [Either String (Maybe NaturalTransformation)]
 -> ExceptT
      NatTransReadError
      (State SDNamespace)
      [Either String (Maybe NaturalTransformation)])
-> State SDNamespace [Either String (Maybe NaturalTransformation)]
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     [Either String (Maybe NaturalTransformation)]
forall a b. (a -> b) -> a -> b
$ (CompElement
 -> State SDNamespace (Either String (Maybe NaturalTransformation)))
-> [CompElement]
-> State SDNamespace [Either String (Maybe NaturalTransformation)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExceptT String (State SDNamespace) (Maybe NaturalTransformation)
-> State SDNamespace (Either String (Maybe NaturalTransformation))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT(ExceptT String (State SDNamespace) (Maybe NaturalTransformation)
 -> State SDNamespace (Either String (Maybe NaturalTransformation)))
-> (CompElement
    -> ExceptT
         String (State SDNamespace) (Maybe NaturalTransformation))
-> CompElement
-> State SDNamespace (Either String (Maybe NaturalTransformation))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CompElement
-> ExceptT String (State SDNamespace) (Maybe NaturalTransformation)
ce_to_nt) [CompElement]
list
         let lookup_errs :: [(Int, Either String (Maybe NaturalTransformation))]
lookup_errs = ((Int, Either String (Maybe NaturalTransformation)) -> Bool)
-> [(Int, Either String (Maybe NaturalTransformation))]
-> [(Int, Either String (Maybe NaturalTransformation))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Either String (Maybe NaturalTransformation) -> Bool
forall a b. Either a b -> Bool
isLeft(Either String (Maybe NaturalTransformation) -> Bool)
-> ((Int, Either String (Maybe NaturalTransformation))
    -> Either String (Maybe NaturalTransformation))
-> (Int, Either String (Maybe NaturalTransformation))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, Either String (Maybe NaturalTransformation))
-> Either String (Maybe NaturalTransformation)
forall a b. (a, b) -> b
snd) ([(Int, Either String (Maybe NaturalTransformation))]
 -> [(Int, Either String (Maybe NaturalTransformation))])
-> [(Int, Either String (Maybe NaturalTransformation))]
-> [(Int, Either String (Maybe NaturalTransformation))]
forall a b. (a -> b) -> a -> b
$ [Int]
-> [Either String (Maybe NaturalTransformation)]
-> [(Int, Either String (Maybe NaturalTransformation))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Either String (Maybe NaturalTransformation)]
found_list
         if [(Int, Either String (Maybe NaturalTransformation))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Either String (Maybe NaturalTransformation))]
lookup_errs
         then [Maybe NaturalTransformation]
-> ExceptT
     NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe NaturalTransformation]
 -> ExceptT
      NatTransReadError
      (State SDNamespace)
      [Maybe NaturalTransformation])
-> [Maybe NaturalTransformation]
-> ExceptT
     NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
forall a b. (a -> b) -> a -> b
$ (Either String (Maybe NaturalTransformation)
 -> Maybe NaturalTransformation)
-> [Either String (Maybe NaturalTransformation)]
-> [Maybe NaturalTransformation]
forall a b. (a -> b) -> [a] -> [b]
map (\(Right Maybe NaturalTransformation
r) -> Maybe NaturalTransformation
r) [Either String (Maybe NaturalTransformation)]
found_list
         else NatTransReadError
-> ExceptT
     NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NatTransReadError
 -> ExceptT
      NatTransReadError
      (State SDNamespace)
      [Maybe NaturalTransformation])
-> NatTransReadError
-> ExceptT
     NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, String)] -> NatTransReadError
LookupNatTransError Int
m ([(Int, String)] -> NatTransReadError)
-> [(Int, String)] -> NatTransReadError
forall a b. (a -> b) -> a -> b
$ ((Int, Either String (Maybe NaturalTransformation))
 -> (Int, String))
-> [(Int, Either String (Maybe NaturalTransformation))]
-> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
n,Left String
eid)->(Int
n,String
eid)) [(Int, Either String (Maybe NaturalTransformation))]
lookup_errs

-- | 'ce_to_nt' of a 'CompElement' gives @Nothing@ if the 'CompElement' is @Nothing@,
-- gives @Just@ the corresponding natural transformation from 'SDNamespace', or
-- throws the id of the 'CompElement' as an error if it could not be found in the 'SDNamespace'.
ce_to_nt :: CompElement -> ExceptT String (State SDNamespace) (Maybe NaturalTransformation)
ce_to_nt :: CompElement
-> ExceptT String (State SDNamespace) (Maybe NaturalTransformation)
ce_to_nt CompElement
Empty = Maybe NaturalTransformation
-> ExceptT String (State SDNamespace) (Maybe NaturalTransformation)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NaturalTransformation
forall a. Maybe a
Nothing
ce_to_nt (CompElement String
cid String
opts) = NaturalTransformation -> Maybe NaturalTransformation
forall a. a -> Maybe a
Just (NaturalTransformation -> Maybe NaturalTransformation)
-> ExceptT String (State SDNamespace) NaturalTransformation
-> ExceptT String (State SDNamespace) (Maybe NaturalTransformation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
-> MaybeT (State SDNamespace) NaturalTransformation
-> ExceptT String (State SDNamespace) NaturalTransformation
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT String
cid (MaybeT (State SDNamespace) NaturalTransformation
 -> ExceptT String (State SDNamespace) NaturalTransformation)
-> MaybeT (State SDNamespace) NaturalTransformation
-> ExceptT String (State SDNamespace) NaturalTransformation
forall a b. (a -> b) -> a -> b
$ String
-> String -> MaybeT (State SDNamespace) NaturalTransformation
sdns_chain_lookup_nat String
cid String
opts)

-- | 'impute_missing_nat' takes the current line number, and a list of @Maybe NaturalTransformation@ and 
-- a functor @f@ which is putatively the source of the horizontal composition of the
-- 'NaturalTransformation's in the list.
-- It replaces the @Nothing@s in the list of @Maybe NaturalTransformations@
-- by the identity natural transformation of the corresponding basic functor in the correct position in @f@,
-- throwing an 'ImputationError' if this cannot be done.
impute_missing_nat :: Int -> [Maybe NaturalTransformation] -> Functor -> Except NatTransReadError [NaturalTransformation]
impute_missing_nat :: Int
-> [Maybe NaturalTransformation]
-> Functor
-> Except NatTransReadError [NaturalTransformation]
impute_missing_nat Int
line [Maybe NaturalTransformation]
nats Functor
func = [Maybe NaturalTransformation]
-> [Functor]
-> Int
-> Except NatTransReadError [NaturalTransformation]
impute' [Maybe NaturalTransformation]
nats (Functor -> [Functor]
func_to_single_list Functor
func) Int
0
    where
        impute' :: [Maybe NaturalTransformation] -> [Functor] -> Int -> Except NatTransReadError [NaturalTransformation]
        impute' :: [Maybe NaturalTransformation]
-> [Functor]
-> Int
-> Except NatTransReadError [NaturalTransformation]
impute' [] [Functor]
_ Int
_ = [NaturalTransformation]
-> Except NatTransReadError [NaturalTransformation]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        impute' (Maybe NaturalTransformation
Nothing:[Maybe NaturalTransformation]
_) [] Int
n 
            = NatTransReadError
-> Except NatTransReadError [NaturalTransformation]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NatTransReadError
 -> Except NatTransReadError [NaturalTransformation])
-> NatTransReadError
-> Except NatTransReadError [NaturalTransformation]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> NatTransReadError
ImputationError Int
line Int
n
        impute' (Maybe NaturalTransformation
Nothing:[Maybe NaturalTransformation]
ns) (Functor
f:[Functor]
fs) Int
n 
            = [Maybe NaturalTransformation]
-> [Functor]
-> Int
-> Except NatTransReadError [NaturalTransformation]
impute' [Maybe NaturalTransformation]
ns [Functor]
fs (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Except NatTransReadError [NaturalTransformation]
-> ([NaturalTransformation]
    -> Except NatTransReadError [NaturalTransformation])
-> Except NatTransReadError [NaturalTransformation]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\[NaturalTransformation]
x -> [NaturalTransformation]
-> Except NatTransReadError [NaturalTransformation]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Functor -> NaturalTransformation
identityNaturalTransformation Functor
f)NaturalTransformation
-> [NaturalTransformation] -> [NaturalTransformation]
forall a. a -> [a] -> [a]
:[NaturalTransformation]
x))
        impute' ((Just NaturalTransformation
nat):[Maybe NaturalTransformation]
ns) [Functor]
fs Int
n
            = [Maybe NaturalTransformation]
-> [Functor]
-> Int
-> Except NatTransReadError [NaturalTransformation]
impute' [Maybe NaturalTransformation]
ns (Int -> [Functor] -> [Functor]
forall a. Int -> [a] -> [a]
drop (NaturalTransformation -> Int
nat_source_length NaturalTransformation
nat) [Functor]
fs) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Except NatTransReadError [NaturalTransformation]
-> ([NaturalTransformation]
    -> Except NatTransReadError [NaturalTransformation])
-> Except NatTransReadError [NaturalTransformation]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\[NaturalTransformation]
x -> [NaturalTransformation]
-> Except NatTransReadError [NaturalTransformation]
forall (m :: * -> *) a. Monad m => a -> m a
return (NaturalTransformation
natNaturalTransformation
-> [NaturalTransformation] -> [NaturalTransformation]
forall a. a -> [a] -> [a]
:[NaturalTransformation]
x))
 
-- | 'horz_compose_nats' takes the current line number and a list of pairs @(id,nt)@ where @id@ is
-- the id of the natural transformation @nt@ and attempts to take a horizontal composition of the
-- natural transformations.
-- It throws a 'HorzComposeNatTransError' if the natural transformations are not horizontally
-- composable.
horz_compose_nats :: Int -> [(String,NaturalTransformation)] -> Except NatTransReadError NaturalTransformation
horz_compose_nats :: Int
-> [(String, NaturalTransformation)]
-> Except NatTransReadError NaturalTransformation
horz_compose_nats Int
line [(String, NaturalTransformation)]
list = (NatHorzCompositionError -> NatTransReadError)
-> Except NatHorzCompositionError NaturalTransformation
-> Except NatTransReadError NaturalTransformation
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept NatHorzCompositionError -> NatTransReadError
mExcept (Except NatHorzCompositionError NaturalTransformation
 -> Except NatTransReadError NaturalTransformation)
-> Except NatHorzCompositionError NaturalTransformation
-> Except NatTransReadError NaturalTransformation
forall a b. (a -> b) -> a -> b
$ [NaturalTransformation]
-> Except NatHorzCompositionError NaturalTransformation
nat_horz_compose_with_error ([NaturalTransformation]
 -> Except NatHorzCompositionError NaturalTransformation)
-> [NaturalTransformation]
-> Except NatHorzCompositionError NaturalTransformation
forall a b. (a -> b) -> a -> b
$ ((String, NaturalTransformation) -> NaturalTransformation)
-> [(String, NaturalTransformation)] -> [NaturalTransformation]
forall a b. (a -> b) -> [a] -> [b]
map (String, NaturalTransformation) -> NaturalTransformation
forall a b. (a, b) -> b
snd [(String, NaturalTransformation)]
list
    where
        mExcept :: NatHorzCompositionError -> NatTransReadError
mExcept (NatHorzCompositionError [Int]
errs) 
            = let lefts :: [(String, NaturalTransformation)]
lefts = (Int -> (String, NaturalTransformation))
-> [Int] -> [(String, NaturalTransformation)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> [(String, NaturalTransformation)]
list [(String, NaturalTransformation)]
-> Int -> (String, NaturalTransformation)
forall a. [a] -> Int -> a
!! Int
x) [Int]
errs
                  rights :: [(String, NaturalTransformation)]
rights = (Int -> (String, NaturalTransformation))
-> [Int] -> [(String, NaturalTransformation)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> [(String, NaturalTransformation)]
list [(String, NaturalTransformation)]
-> Int -> (String, NaturalTransformation)
forall a. [a] -> Int -> a
!! (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) [Int]
errs
              in Int -> [(Int, String, Int, String)] -> NatTransReadError
HorzComposeNatTransError Int
line ([(Int, String, Int, String)] -> NatTransReadError)
-> [(Int, String, Int, String)] -> NatTransReadError
forall a b. (a -> b) -> a -> b
$ ((String, NaturalTransformation)
 -> (String, NaturalTransformation)
 -> Int
 -> (Int, String, Int, String))
-> [(String, NaturalTransformation)]
-> [(String, NaturalTransformation)]
-> [Int]
-> [(Int, String, Int, String)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 
                  (\(String
x,NaturalTransformation
_)-> (\(String
a,NaturalTransformation
_)-> (\Int
n -> (Int
n,String
x,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,String
a)))) [(String, NaturalTransformation)]
lefts [(String, NaturalTransformation)]
rights [Int]
errs

-- | 'get_first_fff' takes a list of 'SDDrawLine's and returns the source
-- of the functor they represent along with a 'FunctorFormatting' which is used
-- to format this source functor.
--
-- It throws a 'NoLinesError' if there are no lines in the list, and
-- a 'FirstLineImputationError' if the first 'SDDrawLine' is specifying a line for a natural
-- transformation, and @Empty@ is in the list of 'CompElement's.
-- It also throws errors if the first line cannot be read.
-- (i.e. if the first line is a functor line, then it can throw an 'FRE' error.
-- If the first line is a natural transformation line, then it can throw a 
-- 'LookupNatTransError' or a 'HorzComposeNatTransError').
get_first_fff :: [SDDrawLine] -> ExceptT NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
get_first_fff :: [SDDrawLine]
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
get_first_fff [] = NatTransReadError
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError NatTransReadError
NoLinesError
get_first_fff ((SDDrawFun [CompElement]
ces):[SDDrawLine]
_) = (FunctorReadError -> NatTransReadError)
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Int -> FunctorReadError -> NatTransReadError
FRE Int
0) (ExceptT
   FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
 -> ExceptT
      NatTransReadError (State SDNamespace) (Functor, FunctorFormatting))
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall a b. (a -> b) -> a -> b
$ [CompElement]
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
read_functor_line [CompElement]
ces
get_first_fff ((SDDrawNat [CompElement]
ces):[SDDrawLine]
_) 
    = do [Maybe NaturalTransformation]
elems <- [CompElement]
-> Int
-> ExceptT
     NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
list_ce_to_nt [CompElement]
ces Int
0
         let ids :: [String]
ids = (CompElement -> String) -> [CompElement] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CompElement -> String
ce_id [CompElement]
ces
         let ([Maybe NaturalTransformation]
bads,[Maybe NaturalTransformation]
goods) = (Maybe NaturalTransformation -> Bool)
-> [Maybe NaturalTransformation]
-> ([Maybe NaturalTransformation], [Maybe NaturalTransformation])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Maybe NaturalTransformation -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe NaturalTransformation]
elems
         if [Maybe NaturalTransformation] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Maybe NaturalTransformation] -> Bool)
-> [Maybe NaturalTransformation] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe NaturalTransformation]
bads  
         then 
            do NaturalTransformation
first_nat <- (Identity (Either NatTransReadError NaturalTransformation)
 -> State
      SDNamespace (Either NatTransReadError NaturalTransformation))
-> Except NatTransReadError NaturalTransformation
-> ExceptT
     NatTransReadError (State SDNamespace) NaturalTransformation
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (Either NatTransReadError NaturalTransformation
-> State
     SDNamespace (Either NatTransReadError NaturalTransformation)
forall (m :: * -> *) a. Monad m => a -> m a
return(Either NatTransReadError NaturalTransformation
 -> State
      SDNamespace (Either NatTransReadError NaturalTransformation))
-> (Identity (Either NatTransReadError NaturalTransformation)
    -> Either NatTransReadError NaturalTransformation)
-> Identity (Either NatTransReadError NaturalTransformation)
-> State
     SDNamespace (Either NatTransReadError NaturalTransformation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Identity (Either NatTransReadError NaturalTransformation)
-> Either NatTransReadError NaturalTransformation
forall a. Identity a -> a
runIdentity) (Except NatTransReadError NaturalTransformation
 -> ExceptT
      NatTransReadError (State SDNamespace) NaturalTransformation)
-> Except NatTransReadError NaturalTransformation
-> ExceptT
     NatTransReadError (State SDNamespace) NaturalTransformation
forall a b. (a -> b) -> a -> b
$ Int
-> [(String, NaturalTransformation)]
-> Except NatTransReadError NaturalTransformation
horz_compose_nats Int
0 
                                ([(String, NaturalTransformation)]
 -> Except NatTransReadError NaturalTransformation)
-> [(String, NaturalTransformation)]
-> Except NatTransReadError NaturalTransformation
forall a b. (a -> b) -> a -> b
$ [String]
-> [NaturalTransformation] -> [(String, NaturalTransformation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ids ([NaturalTransformation] -> [(String, NaturalTransformation)])
-> [NaturalTransformation] -> [(String, NaturalTransformation)]
forall a b. (a -> b) -> a -> b
$ (Maybe NaturalTransformation -> NaturalTransformation)
-> [Maybe NaturalTransformation] -> [NaturalTransformation]
forall a b. (a -> b) -> [a] -> [b]
map Maybe NaturalTransformation -> NaturalTransformation
forall a. HasCallStack => Maybe a -> a
fromJust [Maybe NaturalTransformation]
goods
               let f :: Functor
f = NaturalTransformation -> Functor
nat_source NaturalTransformation
first_nat
               (Functor, FunctorFormatting)
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Functor, FunctorFormatting)
 -> ExceptT
      NatTransReadError (State SDNamespace) (Functor, FunctorFormatting))
-> (Functor, FunctorFormatting)
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall a b. (a -> b) -> a -> b
$ (Functor
f, Functor -> FunctorFormatting
default_ff Functor
f)
         else NatTransReadError
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError NatTransReadError
FirstLineImputationError

-- | 'combine_sddl' is a helper function for 'read_nat_trans'.
-- It takes
-- 
-- - The current target functor of the previous lines
--
-- - A @Bool@ which is true if the previous line was a functor line, and false if it was a natural
-- transformation line
--
-- - The current line number
--
-- - The current 'SDDrawLine' for this line
--
-- and it outputs a tuple of
--
-- - The target functor of the new natural transformation
--
-- - A @Bool@ which is true if this line was a functor line and false otherwise
--
-- - The next line number
--
-- - The empty list if the current line was a functor line.
-- A singleton list containing the horizontal composition of the current line
-- for a natural transformation line.
--
-- - The empty list if the current line was a natural transformation line.
-- A singleton list corresponding to the functor formatting of the current line
-- if it is a functor line.
--
-- It throws a 'NatTransReadError' if there was an error in processing this line.
combine_sddl :: Functor -> Bool -> Int -> SDDrawLine -> ExceptT NatTransReadError 
                    (State SDNamespace) (Functor,Bool,Int,[NaturalTransformation],[FunctorFormatting])
combine_sddl :: Functor
-> Bool
-> Int
-> SDDrawLine
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
combine_sddl Functor
_ Bool
True Int
n (SDDrawFun [CompElement]
_) = NatTransReadError
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NatTransReadError
 -> ExceptT
      NatTransReadError
      (State SDNamespace)
      (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting]))
-> NatTransReadError
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall a b. (a -> b) -> a -> b
$ Int -> NatTransReadError
TwoConsecutiveFunctorsError Int
n
combine_sddl Functor
fun Bool
False Int
n (SDDrawFun [CompElement]
ces) 
    = do (Functor
f,FunctorFormatting
ff) <- (FunctorReadError -> NatTransReadError)
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Int -> FunctorReadError -> NatTransReadError
FRE Int
n) (ExceptT
   FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
 -> ExceptT
      NatTransReadError (State SDNamespace) (Functor, FunctorFormatting))
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
forall a b. (a -> b) -> a -> b
$ [CompElement]
-> ExceptT
     FunctorReadError (State SDNamespace) (Functor, FunctorFormatting)
read_functor_line [CompElement]
ces
         if Functor
f Functor -> Functor -> Bool
forall a. Eq a => a -> a -> Bool
== Functor
fun 
         then (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall (m :: * -> *) a. Monad m => a -> m a
return (Functor
fun, Bool
True, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,[], [FunctorFormatting
ff])
         else NatTransReadError
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NatTransReadError
 -> ExceptT
      NatTransReadError
      (State SDNamespace)
      (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting]))
-> NatTransReadError
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall a b. (a -> b) -> a -> b
$ Int -> NatTransReadError
IncompatibleLinesError Int
n
combine_sddl Functor
fun Bool
tf Int
n (SDDrawNat [CompElement]
ces) 
    = do [Maybe NaturalTransformation]
elems <- [CompElement]
-> Int
-> ExceptT
     NatTransReadError (State SDNamespace) [Maybe NaturalTransformation]
list_ce_to_nt [CompElement]
ces Int
n
         [NaturalTransformation]
nats <- (Identity (Either NatTransReadError [NaturalTransformation])
 -> State
      SDNamespace (Either NatTransReadError [NaturalTransformation]))
-> Except NatTransReadError [NaturalTransformation]
-> ExceptT
     NatTransReadError (State SDNamespace) [NaturalTransformation]
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (Either NatTransReadError [NaturalTransformation]
-> State
     SDNamespace (Either NatTransReadError [NaturalTransformation])
forall (m :: * -> *) a. Monad m => a -> m a
return(Either NatTransReadError [NaturalTransformation]
 -> State
      SDNamespace (Either NatTransReadError [NaturalTransformation]))
-> (Identity (Either NatTransReadError [NaturalTransformation])
    -> Either NatTransReadError [NaturalTransformation])
-> Identity (Either NatTransReadError [NaturalTransformation])
-> State
     SDNamespace (Either NatTransReadError [NaturalTransformation])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Identity (Either NatTransReadError [NaturalTransformation])
-> Either NatTransReadError [NaturalTransformation]
forall a. Identity a -> a
runIdentity) (Except NatTransReadError [NaturalTransformation]
 -> ExceptT
      NatTransReadError (State SDNamespace) [NaturalTransformation])
-> Except NatTransReadError [NaturalTransformation]
-> ExceptT
     NatTransReadError (State SDNamespace) [NaturalTransformation]
forall a b. (a -> b) -> a -> b
$ Int
-> [Maybe NaturalTransformation]
-> Functor
-> Except NatTransReadError [NaturalTransformation]
impute_missing_nat Int
n [Maybe NaturalTransformation]
elems Functor
fun
         NaturalTransformation
c_nat <- (Identity (Either NatTransReadError NaturalTransformation)
 -> State
      SDNamespace (Either NatTransReadError NaturalTransformation))
-> Except NatTransReadError NaturalTransformation
-> ExceptT
     NatTransReadError (State SDNamespace) NaturalTransformation
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (Either NatTransReadError NaturalTransformation
-> State
     SDNamespace (Either NatTransReadError NaturalTransformation)
forall (m :: * -> *) a. Monad m => a -> m a
return(Either NatTransReadError NaturalTransformation
 -> State
      SDNamespace (Either NatTransReadError NaturalTransformation))
-> (Identity (Either NatTransReadError NaturalTransformation)
    -> Either NatTransReadError NaturalTransformation)
-> Identity (Either NatTransReadError NaturalTransformation)
-> State
     SDNamespace (Either NatTransReadError NaturalTransformation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Identity (Either NatTransReadError NaturalTransformation)
-> Either NatTransReadError NaturalTransformation
forall a. Identity a -> a
runIdentity) (Except NatTransReadError NaturalTransformation
 -> ExceptT
      NatTransReadError (State SDNamespace) NaturalTransformation)
-> Except NatTransReadError NaturalTransformation
-> ExceptT
     NatTransReadError (State SDNamespace) NaturalTransformation
forall a b. (a -> b) -> a -> b
$ 
                      Int
-> [(String, NaturalTransformation)]
-> Except NatTransReadError NaturalTransformation
horz_compose_nats Int
n ([(String, NaturalTransformation)]
 -> Except NatTransReadError NaturalTransformation)
-> [(String, NaturalTransformation)]
-> Except NatTransReadError NaturalTransformation
forall a b. (a -> b) -> a -> b
$ [String]
-> [NaturalTransformation] -> [(String, NaturalTransformation)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((NaturalTransformation -> String)
-> [NaturalTransformation] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NaturalTransformation -> String
forall a. Structure a => a -> String
get_id [NaturalTransformation]
nats) [NaturalTransformation]
nats
         case NaturalTransformation -> Functor
nat_source NaturalTransformation
c_nat Functor -> Functor -> Bool
forall a. Eq a => a -> a -> Bool
== Functor
fun of 
              Bool
True -> if Bool
tf 
                      then (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall (m :: * -> *) a. Monad m => a -> m a
return (NaturalTransformation -> Functor
nat_target NaturalTransformation
c_nat, Bool
False,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, [NaturalTransformation
c_nat], [])
                      else (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall (m :: * -> *) a. Monad m => a -> m a
return (NaturalTransformation -> Functor
nat_target NaturalTransformation
c_nat, Bool
False, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,[NaturalTransformation
c_nat], [Functor -> FunctorFormatting
default_ff (Functor -> FunctorFormatting) -> Functor -> FunctorFormatting
forall a b. (a -> b) -> a -> b
$ NaturalTransformation -> Functor
nat_source NaturalTransformation
c_nat])
              Bool
False -> NatTransReadError
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NatTransReadError
 -> ExceptT
      NatTransReadError
      (State SDNamespace)
      (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting]))
-> NatTransReadError
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall a b. (a -> b) -> a -> b
$ Int -> NatTransReadError
IncompatibleLinesError Int
n

-- | 'read_nat_trans' takes a list of 'SDDrawLine's and returns a pair @(nt,nf)@
-- where @nt@ is the 'NaturalTransformation' specified by this list of 'SDDrawLine's,
-- and @nf@ is the 'NatFormatting' specified by the list, used to format @nt@.
--
-- It throws a 'NatTransReadError' if there was an error in processing the list.
read_nat_trans :: [SDDrawLine] -> ExceptT NatTransReadError (State SDNamespace) (NaturalTransformation,NatFormatting)
read_nat_trans :: [SDDrawLine]
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (NaturalTransformation, [FunctorFormatting])
read_nat_trans [SDDrawLine]
sdls 
    = do (Functor
f,FunctorFormatting
_) <- [SDDrawLine]
-> ExceptT
     NatTransReadError (State SDNamespace) (Functor, FunctorFormatting)
get_first_fff [SDDrawLine]
sdls
         (Functor
fun, Bool
tf, Int
_, [NaturalTransformation]
nats, [FunctorFormatting]
ffs) <- ((Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
 -> SDDrawLine
 -> ExceptT
      NatTransReadError
      (State SDNamespace)
      (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting]))
-> (Functor, Bool, Int, [NaturalTransformation],
    [FunctorFormatting])
-> [SDDrawLine]
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
-> SDDrawLine
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
helper (Functor
f,Bool
False,Int
0,[],[]) [SDDrawLine]
sdls
         (Identity (Either NatTransReadError ())
 -> State SDNamespace (Either NatTransReadError ()))
-> ExceptT NatTransReadError Identity ()
-> ExceptT NatTransReadError (State SDNamespace) ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (Either NatTransReadError ()
-> State SDNamespace (Either NatTransReadError ())
forall (m :: * -> *) a. Monad m => a -> m a
return(Either NatTransReadError ()
 -> State SDNamespace (Either NatTransReadError ()))
-> (Identity (Either NatTransReadError ())
    -> Either NatTransReadError ())
-> Identity (Either NatTransReadError ())
-> State SDNamespace (Either NatTransReadError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Identity (Either NatTransReadError ())
-> Either NatTransReadError ()
forall a. Identity a -> a
runIdentity) (ExceptT NatTransReadError Identity ()
 -> ExceptT NatTransReadError (State SDNamespace) ())
-> ExceptT NatTransReadError Identity ()
-> ExceptT NatTransReadError (State SDNamespace) ()
forall a b. (a -> b) -> a -> b
$ [NaturalTransformation] -> ExceptT NatTransReadError Identity ()
check_nonempty [NaturalTransformation]
nats
         let final_ffs :: [FunctorFormatting]
final_ffs = Functor -> Bool -> [FunctorFormatting] -> [FunctorFormatting]
add_final_ff Functor
fun Bool
tf [FunctorFormatting]
ffs
         (NaturalTransformation, [FunctorFormatting])
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (NaturalTransformation, [FunctorFormatting])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NaturalTransformation -> NaturalTransformation
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe NaturalTransformation -> NaturalTransformation)
-> Maybe NaturalTransformation -> NaturalTransformation
forall a b. (a -> b) -> a -> b
$ [NaturalTransformation] -> Maybe NaturalTransformation
nat_vert_compose [NaturalTransformation]
nats, [FunctorFormatting]
final_ffs)
    where
        helper :: (Functor,Bool,Int,[NaturalTransformation],[FunctorFormatting]) -> SDDrawLine 
                    -> ExceptT NatTransReadError (State SDNamespace) 
                                (Functor,Bool,Int,[NaturalTransformation],[FunctorFormatting])
        helper :: (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
-> SDDrawLine
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
helper (Functor
f,Bool
b,Int
i,[NaturalTransformation]
nts,[FunctorFormatting]
ffs) SDDrawLine
sddl = do (Functor
next_f,Bool
next_b, Int
next_i, [NaturalTransformation]
new_nts, [FunctorFormatting]
new_ffs) <- Functor
-> Bool
-> Int
-> SDDrawLine
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
combine_sddl Functor
f Bool
b Int
i SDDrawLine
sddl
                                         (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (Functor, Bool, Int, [NaturalTransformation], [FunctorFormatting])
forall (m :: * -> *) a. Monad m => a -> m a
return (Functor
next_f,Bool
next_b,Int
next_i,[NaturalTransformation]
nts[NaturalTransformation]
-> [NaturalTransformation] -> [NaturalTransformation]
forall a. [a] -> [a] -> [a]
++[NaturalTransformation]
new_nts,[FunctorFormatting]
ffs[FunctorFormatting] -> [FunctorFormatting] -> [FunctorFormatting]
forall a. [a] -> [a] -> [a]
++[FunctorFormatting]
new_ffs)
        check_nonempty :: [NaturalTransformation] -> Except NatTransReadError ()
        check_nonempty :: [NaturalTransformation] -> ExceptT NatTransReadError Identity ()
check_nonempty [] = NatTransReadError -> ExceptT NatTransReadError Identity ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError NatTransReadError
NoLinesError
        check_nonempty [NaturalTransformation]
_ = () -> ExceptT NatTransReadError Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        add_final_ff :: Functor -> Bool -> [FunctorFormatting] -> [FunctorFormatting]
        add_final_ff :: Functor -> Bool -> [FunctorFormatting] -> [FunctorFormatting]
add_final_ff Functor
fun Bool
False [FunctorFormatting]
ffs = [FunctorFormatting]
ffs[FunctorFormatting] -> [FunctorFormatting] -> [FunctorFormatting]
forall a. [a] -> [a] -> [a]
++[Functor -> FunctorFormatting
default_ff Functor
fun]
        add_final_ff Functor
_ Bool
True [FunctorFormatting]
ffs = [FunctorFormatting]
ffs

-- | A partial function on 'SDCommand's which were constructed using 'DrawNat'.
-- See 'handle_sdc'.
handle_draw_nat :: SDCommand -> State SDNamespace (IO ())
handle_draw_nat :: SDCommand -> State SDNamespace (IO ())
handle_draw_nat (DrawNat String
fn String
opts [SDDrawLine]
ces) 
    = do Either
  NatTransReadError (NaturalTransformation, [FunctorFormatting])
e_or_nt_nf <- ExceptT
  NatTransReadError
  (State SDNamespace)
  (NaturalTransformation, [FunctorFormatting])
-> State
     SDNamespace
     (Either
        NatTransReadError (NaturalTransformation, [FunctorFormatting]))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   NatTransReadError
   (State SDNamespace)
   (NaturalTransformation, [FunctorFormatting])
 -> State
      SDNamespace
      (Either
         NatTransReadError (NaturalTransformation, [FunctorFormatting])))
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (NaturalTransformation, [FunctorFormatting])
-> State
     SDNamespace
     (Either
        NatTransReadError (NaturalTransformation, [FunctorFormatting]))
forall a b. (a -> b) -> a -> b
$ [SDDrawLine]
-> ExceptT
     NatTransReadError
     (State SDNamespace)
     (NaturalTransformation, [FunctorFormatting])
read_nat_trans [SDDrawLine]
ces
         case Either
  NatTransReadError (NaturalTransformation, [FunctorFormatting])
e_or_nt_nf of 
              Left NatTransReadError
e -> IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (NatTransReadError -> String
forall a. Error a => a -> String
error_msg NatTransReadError
e) 
                                     String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n\tWhen drawing the natural transformation "
                                     String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"with output file "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fn
              Right (NaturalTransformation
nt,[FunctorFormatting]
nf) -> do let tikzsd :: TikzStringDiagram
tikzsd = NaturalTransformation
-> [FunctorFormatting] -> String -> TikzStringDiagram
make_tikzsd NaturalTransformation
nt [FunctorFormatting]
nf String
opts
                                  IO () -> State SDNamespace (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> State SDNamespace (IO ()))
-> IO () -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
fn (TikzStringDiagram -> String
forall a. ShowLatex a => a -> String
showLatex TikzStringDiagram
tikzsd)
handle_draw_nat SDCommand
_ 
    = String -> State SDNamespace (IO ())
forall a. HasCallStack => String -> a
error (String -> State SDNamespace (IO ()))
-> String -> State SDNamespace (IO ())
forall a b. (a -> b) -> a -> b
$ String
"Error! handle_draw_nat should only be called by handle_sdc,"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" which should only call handle_draw_nat when handling"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" DrawNat SDCommands"

-- | 'handle_sdc' takse an 'SDCommand' and does the corresponding action.
-- For define commands, it adds the corresponding object to the 'SDNamespace' state.
-- For 'DrawNat' commands, it writes the LaTeX code for the specified string diagram to the
-- specified file.
--
-- It prints an error message to @stderr@ describing the problem if the command could not be
-- executed.
--
-- This function is broken up into the partially defined functions 'handle_def_cat',
-- 'handle_def_fun', 'handle_def_nat' and 'handle_draw_nat'.
handle_sdc :: SDCommand -> State SDNamespace (IO ())
handle_sdc :: SDCommand -> State SDNamespace (IO ())
handle_sdc (DefineCat String
cid String
ds) 
    = SDCommand -> State SDNamespace (IO ())
handle_def_cat (String -> String -> SDCommand
DefineCat String
cid String
ds)
handle_sdc (DefineFunc String
fid String
ds String
source_id String
target_id String
opts) 
    = SDCommand -> State SDNamespace (IO ())
handle_def_fun (String -> String -> String -> String -> String -> SDCommand
DefineFunc String
fid String
ds String
source_id String
target_id String
opts)
handle_sdc (DefineNat String
ntid String
ds [CompElement]
source [CompElement]
target String
opts String
shape) 
    = SDCommand -> State SDNamespace (IO ())
handle_def_nat (String
-> String
-> [CompElement]
-> [CompElement]
-> String
-> String
-> SDCommand
DefineNat String
ntid String
ds [CompElement]
source [CompElement]
target String
opts String
shape)
handle_sdc (DrawNat String
fn String
opts [SDDrawLine]
ces) 
    = SDCommand -> State SDNamespace (IO ())
handle_draw_nat (String -> String -> [SDDrawLine] -> SDCommand
DrawNat String
fn String
opts [SDDrawLine]
ces)