{-| Module  : FiniteCategories
Description : A parser to read .cg files.
Copyright   : Guillaume Sabbagh 2021
License     : GPL-3
Maintainer  : guillaumesabbagh@protonmail.com
Stability   : experimental
Portability : portable

A parser to read .cg files.

A .cg file follows the following rules :
    1. Each line defines either an object, a morphism or a composition law entry.
    2. The following strings are reserved : ' -','-> ',' = '
    3. To define an object, write a line containing its name.
    4. To define an arrow, the syntax "source_object -name_of_morphism-> target_object" is used, where "source_object", "target_object" and "name_of_morphism" should be replaced.
    4.1. If an object mentionned does not exist, it is created.
    4.2. The spaces are important. 
    5. To define a composition law entry, the syntax "source_object1 -name_of_first_morphism-> middle_object -name_of_second_morphism-> target_object1 = source_object2 -name_of_composite_morphism-> target_object2" is used, where "source_object1", "name_of_first_morphism", "middle_object", "name_of_second_morphism", "target_object1", "source_object2", "name_of_composite_morphism", "target_object2" should be replaced.
    5.1 If an object mentionned does not exist, it is created.
    5.2 If a morphism mentionned does not exist, it is created.
    5.3 You can use the tag <ID/> in order to map a morphism to an identity.
-}

module IO.Parsers.CompositionGraph
(
    readCGFile,
    writeCGFile
)
where
    import FiniteCategory.FiniteCategory
    import CompositionGraph.CompositionGraph
    import IO.Parsers.Lexer
    import Data.IORef
    import Data.Text (Text, pack, unpack)
    import Data.List (elemIndex, nub, intercalate)
    import Utils.Tuple
    import IO.PrettyPrint
    
    import System.Directory (createDirectoryIfMissing)
    import System.FilePath.Posix (takeDirectory)
    
    type CG = CompositionGraph Text Text
    
    addObject :: [Token] -> CG -> CG
    addObject :: [Token] -> CG -> CG
addObject [Name Text
str] cg :: CG
cg@CompositionGraph{graph :: forall a b. CompositionGraph a b -> Graph a b
graph=([Text]
n,[Arrow Text Text]
a),law :: forall a b. CompositionGraph a b -> CompositionLaw a b
law=CompositionLaw Text Text
l} = if Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
str (CG -> [Text]
forall c m o. FiniteCategory c m o => c -> [o]
ob CG
cg) then CG
cg else CompositionGraph :: forall a b. Graph a b -> CompositionLaw a b -> CompositionGraph a b
CompositionGraph{graph :: ([Text], [Arrow Text Text])
graph=((Text
strText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:(CG -> [Text]
forall c m o. FiniteCategory c m o => c -> [o]
ob CG
cg)),[Arrow Text Text]
a),law :: CompositionLaw Text Text
law=CompositionLaw Text Text
l}
    addObject [Token]
otherTokens CG
_ = [Char] -> CG
forall a. HasCallStack => [Char] -> a
error ([Char] -> CG) -> [Char] -> CG
forall a b. (a -> b) -> a -> b
$ [Char]
"addObject on invalid tokens : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Token] -> [Char]
forall a. Show a => a -> [Char]
show [Token]
otherTokens
    
    addMorphism :: [Token] -> CG -> CG
    addMorphism :: [Token] -> CG -> CG
addMorphism [Name Text
src, Token
BeginArrow, Name Text
arr, Token
EndArrow, Name Text
tgt] CG
cg = if Maybe Text -> [Maybe Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
arr) (CGMorphism Text Text -> Maybe Text
forall a b. Eq a => CGMorphism a b -> Maybe b
getLabel (CGMorphism Text Text -> Maybe Text)
-> [CGMorphism Text Text] -> [Maybe Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CG -> Text -> Text -> [CGMorphism Text Text]
forall c m o.
(FiniteCategory c m o, Morphism m o) =>
c -> o -> o -> [m]
ar CG
newCG2 Text
src Text
tgt)) then CG
newCG2 else CompositionGraph :: forall a b. Graph a b -> CompositionLaw a b -> CompositionGraph a b
CompositionGraph{graph :: ([Text], [Arrow Text Text])
graph=([Text]
n,((Text
src,Text
tgt,Text
arr)Arrow Text Text -> [Arrow Text Text] -> [Arrow Text Text]
forall a. a -> [a] -> [a]
:[Arrow Text Text]
a)),law :: CompositionLaw Text Text
law=CompositionLaw Text Text
l}
        where
            newCG1 :: CG
newCG1 = [Token] -> CG -> CG
addObject [Text -> Token
Name Text
src] CG
cg
            newCG2 :: CG
newCG2@CompositionGraph{graph :: forall a b. CompositionGraph a b -> Graph a b
graph=([Text]
n,[Arrow Text Text]
a),law :: forall a b. CompositionGraph a b -> CompositionLaw a b
law=CompositionLaw Text Text
l} = [Token] -> CG -> CG
addObject [Text -> Token
Name Text
tgt] CG
newCG1
    addMorphism [Token]
otherTokens CG
_ = [Char] -> CG
forall a. HasCallStack => [Char] -> a
error ([Char] -> CG) -> [Char] -> CG
forall a b. (a -> b) -> a -> b
$ [Char]
"addMorphism on invalid tokens : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Token] -> [Char]
forall a. Show a => a -> [Char]
show [Token]
otherTokens
    
    extractPath :: [Token] -> RawPath Text Text
    extractPath :: [Token] -> [Arrow Text Text]
extractPath [] = []
    extractPath [Token
Identity] = []
    extractPath [(Name Text
_)] = []
    extractPath ((Name Text
src) : (Token
BeginArrow : ((Name Text
arr) : (Token
EndArrow : ((Name Text
tgt) : [Token]
ts))))) = ([Token] -> [Arrow Text Text]
extractPath ((Text -> Token
Name Text
tgt) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
ts)) [Arrow Text Text] -> [Arrow Text Text] -> [Arrow Text Text]
forall a. [a] -> [a] -> [a]
++ [(Text
src,Text
tgt,Text
arr)]
    extractPath [Token]
otherTokens = [Char] -> [Arrow Text Text]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Arrow Text Text]) -> [Char] -> [Arrow Text Text]
forall a b. (a -> b) -> a -> b
$ [Char]
"extractPath on invalid tokens : "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Token] -> [Char]
forall a. Show a => a -> [Char]
show [Token]
otherTokens
    
    addCompositionLawEntry :: [Token] -> CG -> CG
    addCompositionLawEntry :: [Token] -> CG -> CG
addCompositionLawEntry [Token]
tokens cg :: CG
cg@CompositionGraph{graph :: forall a b. CompositionGraph a b -> Graph a b
graph=([Text]
n,[Arrow Text Text]
a),law :: forall a b. CompositionGraph a b -> CompositionLaw a b
law=CompositionLaw Text Text
l} = CompositionGraph :: forall a b. Graph a b -> CompositionLaw a b -> CompositionGraph a b
CompositionGraph{graph :: ([Text], [Arrow Text Text])
graph=([Text]
n[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++[Text]
newObj,[Arrow Text Text]
a[Arrow Text Text] -> [Arrow Text Text] -> [Arrow Text Text]
forall a. [a] -> [a] -> [a]
++[Arrow Text Text]
newMorph),law :: CompositionLaw Text Text
law=([Arrow Text Text]
pathLeft,[Arrow Text Text]
pathRight)([Arrow Text Text], [Arrow Text Text])
-> CompositionLaw Text Text -> CompositionLaw Text Text
forall a. a -> [a] -> [a]
:CompositionLaw Text Text
l}
        where
            Just Int
indexEquals = Token -> [Token] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Token
Equals [Token]
tokens
            ([Token]
tokensLeft,(Token
_:[Token]
tokensRight)) = Int -> [Token] -> ([Token], [Token])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
indexEquals [Token]
tokens
            pathLeft :: [Arrow Text Text]
pathLeft = [Token] -> [Arrow Text Text]
extractPath [Token]
tokensLeft
            pathRight :: [Arrow Text Text]
pathRight = [Token] -> [Arrow Text Text]
extractPath [Token]
tokensRight
            newObj :: [Text]
newObj = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text
s | (Text
s,Text
_,Text
_) <- [Arrow Text Text]
pathLeft[Arrow Text Text] -> [Arrow Text Text] -> [Arrow Text Text]
forall a. [a] -> [a] -> [a]
++[Arrow Text Text]
pathRight, Bool -> Bool
not (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
s [Text]
n)][Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++[Text
t | (Text
_,Text
t,Text
_) <- [Arrow Text Text]
pathLeft[Arrow Text Text] -> [Arrow Text Text] -> [Arrow Text Text]
forall a. [a] -> [a] -> [a]
++[Arrow Text Text]
pathRight, Bool -> Bool
not (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
t [Text]
n)]
            newMorph :: [Arrow Text Text]
newMorph = [Arrow Text Text] -> [Arrow Text Text]
forall a. Eq a => [a] -> [a]
nub [Arrow Text Text
e | Arrow Text Text
e <- [Arrow Text Text]
pathLeft[Arrow Text Text] -> [Arrow Text Text] -> [Arrow Text Text]
forall a. [a] -> [a] -> [a]
++[Arrow Text Text]
pathRight, Bool -> Bool
not (Arrow Text Text -> [Arrow Text Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Arrow Text Text
e [Arrow Text Text]
a)]
    
    readLine :: String -> CG -> CG
    readLine :: [Char] -> CG -> CG
readLine [Char]
line CG
cg
        | [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
lexedLine = CG
cg
        | Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Token
Equals [Token]
lexedLine = [Token] -> CG -> CG
addCompositionLawEntry [Token]
lexedLine CG
cg
        | Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Token
BeginArrow [Token]
lexedLine = [Token] -> CG -> CG
addMorphism [Token]
lexedLine CG
cg
        | Bool
otherwise = [Token] -> CG -> CG
addObject [Token]
lexedLine CG
cg
        where
            lexedLine :: [Token]
lexedLine = ([Char] -> [Token]
parserLex [Char]
line)
    
    parseCGString :: String -> CG
    parseCGString :: [Char] -> CG
parseCGString [Char]
str = CG
newCG
        where
            ls :: [[Char]]
ls = [Char] -> [[Char]]
lines [Char]
str
            cg :: CompositionGraph a b
cg = CompositionGraph a b
forall a b. CompositionGraph a b
mkEmptyCompositionGraph
            newCG :: CG
newCG = ([Char] -> CG -> CG) -> CG -> [[Char]] -> CG
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> CG -> CG
readLine CG
forall a b. CompositionGraph a b
cg [[Char]]
ls
    
    -- | Reads a cg file and returns a composition graph.

    readCGFile :: String -> IO CG
    readCGFile :: [Char] -> IO CG
readCGFile [Char]
path = do
        [Char]
file <- [Char] -> IO [Char]
readFile [Char]
path
        CG -> IO CG
forall (m :: * -> *) a. Monad m => a -> m a
return (CG -> IO CG) -> CG -> IO CG
forall a b. (a -> b) -> a -> b
$ [Char] -> CG
parseCGString [Char]
file
        
    reversedRawPathToString :: (PrettyPrintable a, PrettyPrintable b) => RawPath a b -> String
    reversedRawPathToString :: forall a b.
(PrettyPrintable a, PrettyPrintable b) =>
RawPath a b -> [Char]
reversedRawPathToString [] = [Char]
"<ID>"
    reversedRawPathToString [(a
s,a
t,b
l)] = a -> [Char]
forall a. PrettyPrintable a => a -> [Char]
pprint a
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ b -> [Char]
forall a. PrettyPrintable a => a -> [Char]
pprint b
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. PrettyPrintable a => a -> [Char]
pprint a
t
    reversedRawPathToString ((a
s,a
t,b
l):[Arrow a b]
xs) = a -> [Char]
forall a. PrettyPrintable a => a -> [Char]
pprint a
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ b -> [Char]
forall a. PrettyPrintable a => a -> [Char]
pprint b
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Arrow a b] -> [Char]
forall a b.
(PrettyPrintable a, PrettyPrintable b) =>
RawPath a b -> [Char]
reversedRawPathToString [Arrow a b]
xs
    
    unparseCG :: (PrettyPrintable a, PrettyPrintable b, Eq a, Eq b) => CompositionGraph a b -> String
    unparseCG :: forall a b.
(PrettyPrintable a, PrettyPrintable b, Eq a, Eq b) =>
CompositionGraph a b -> [Char]
unparseCG CompositionGraph a b
cg = [Char]
finalString
        where
            obString :: [Char]
obString = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. PrettyPrintable a => a -> [Char]
pprint (a -> [Char]) -> [a] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompositionGraph a b -> [a]
forall c m o. FiniteCategory c m o => c -> [o]
ob CompositionGraph a b
cg
            arNotIdentity :: [CGMorphism a b]
arNotIdentity = (CGMorphism a b -> Bool) -> [CGMorphism a b] -> [CGMorphism a b]
forall a. (a -> Bool) -> [a] -> [a]
filter (CompositionGraph a b -> CGMorphism a b -> Bool
forall c m o.
(FiniteCategory c m o, Morphism m o, Eq m, Eq o) =>
c -> m -> Bool
isNotIdentity CompositionGraph a b
cg) (CompositionGraph a b -> [CGMorphism a b]
forall c m o.
(GeneratedFiniteCategory c m o, GeneratedFiniteCategory c m o,
 Morphism m o) =>
c -> [m]
genArrows CompositionGraph a b
cg)
            reversedRawPaths :: [[Arrow a b]]
reversedRawPaths = ([Arrow a b] -> [Arrow a b]
forall a. [a] -> [a]
reverse([Arrow a b] -> [Arrow a b])
-> (CGMorphism a b -> [Arrow a b]) -> CGMorphism a b -> [Arrow a b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, [Arrow a b], a) -> [Arrow a b]
forall a b c. (a, b, c) -> b
snd3((a, [Arrow a b], a) -> [Arrow a b])
-> (CGMorphism a b -> (a, [Arrow a b], a))
-> CGMorphism a b
-> [Arrow a b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CGMorphism a b -> (a, [Arrow a b], a)
forall a b. CGMorphism a b -> Path a b
path) (CGMorphism a b -> [Arrow a b])
-> [CGMorphism a b] -> [[Arrow a b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CGMorphism a b]
arNotIdentity
            arStringBeforeComment :: [[Char]]
arStringBeforeComment = [Arrow a b] -> [Char]
forall a b.
(PrettyPrintable a, PrettyPrintable b) =>
RawPath a b -> [Char]
reversedRawPathToString ([Arrow a b] -> [Char]) -> [[Arrow a b]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Arrow a b]]
reversedRawPaths
            commentOutComposite :: [[Char]]
commentOutComposite = [if CompositionGraph a b -> CGMorphism a b -> Bool
forall c m o.
(GeneratedFiniteCategory c m o, Morphism m o, Eq m) =>
c -> m -> Bool
isComposite CompositionGraph a b
cg CGMorphism a b
m then (Char
'#'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
s) else [Char]
s | ([Char]
s,CGMorphism a b
m) <- [[Char]] -> [CGMorphism a b] -> [([Char], CGMorphism a b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
arStringBeforeComment [CGMorphism a b]
arNotIdentity]
            arString :: [Char]
arString = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]]
commentOutComposite
            lawString :: [Char]
lawString = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (\([Arrow a b]
rp1,[Arrow a b]
rp2) -> ([Arrow a b] -> [Char]
forall a b.
(PrettyPrintable a, PrettyPrintable b) =>
RawPath a b -> [Char]
reversedRawPathToString ([Arrow a b] -> [Arrow a b]
forall a. [a] -> [a]
reverse [Arrow a b]
rp1)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Arrow a b] -> [Char]
forall a b.
(PrettyPrintable a, PrettyPrintable b) =>
RawPath a b -> [Char]
reversedRawPathToString ([Arrow a b] -> [Arrow a b]
forall a. [a] -> [a]
reverse [Arrow a b]
rp2))) (([Arrow a b], [Arrow a b]) -> [Char])
-> [([Arrow a b], [Arrow a b])] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompositionGraph a b -> [([Arrow a b], [Arrow a b])]
forall a b. CompositionGraph a b -> CompositionLaw a b
law CompositionGraph a b
cg)
            finalString :: [Char]
finalString = [Char]
"#Objects :\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
obString[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n\n# Arrows :\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
arString[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n\n# Composition law :\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
lawString
    
    -- | Saves a composition graph into a file located at a given path.

    writeCGFile :: (PrettyPrintable a, PrettyPrintable b, Eq a, Eq b) => CompositionGraph a b -> String -> IO ()
    writeCGFile :: forall a b.
(PrettyPrintable a, PrettyPrintable b, Eq a, Eq b) =>
CompositionGraph a b -> [Char] -> IO ()
writeCGFile CompositionGraph a b
cg [Char]
filepath = do
        Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
takeDirectory [Char]
filepath
        [Char] -> [Char] -> IO ()
writeFile [Char]
filepath ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ CompositionGraph a b -> [Char]
forall a b.
(PrettyPrintable a, PrettyPrintable b, Eq a, Eq b) =>
CompositionGraph a b -> [Char]
unparseCG CompositionGraph a b
cg