CompositionGraph.hs

{-| 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 [Name str] cg@CompositionGraph{graph=(n,a),law=l} = if elem str (ob cg) then cg else CompositionGraph{graph=((str:(ob cg)),a),law=l}
    addObject otherTokens _ = error $ "addObject on invalid tokens : "++show otherTokens
    
    addMorphism :: [Token] -> CG -> CG
    addMorphism [Name src, BeginArrow, Name arr, EndArrow, Name tgt] cg = if elem (Just arr) (getLabel <$> (ar newCG2 src tgt)) then newCG2 else CompositionGraph{graph=(n,((src,tgt,arr):a)),law=l}
        where
            newCG1 = addObject [Name src] cg
            newCG2@CompositionGraph{graph=(n,a),law=l} = addObject [Name tgt] newCG1
    addMorphism otherTokens _ = error $ "addMorphism on invalid tokens : "++show otherTokens
    
    extractPath :: [Token] -> RawPath Text Text
    extractPath [] = []
    extractPath [Identity] = []
    extractPath [(Name _)] = []
    extractPath ((Name src) : (BeginArrow : ((Name arr) : (EndArrow : ((Name tgt) : ts))))) = (extractPath ((Name tgt) : ts)) ++ [(src,tgt,arr)]
    extractPath otherTokens = error $ "extractPath on invalid tokens : "++show otherTokens
    
    addCompositionLawEntry :: [Token] -> CG -> CG
    addCompositionLawEntry tokens cg@CompositionGraph{graph=(n,a),law=l} = CompositionGraph{graph=(n++newObj,a++newMorph),law=(pathLeft,pathRight):l}
        where
            Just indexEquals = elemIndex Equals tokens
            (tokensLeft,(_:tokensRight)) = splitAt indexEquals tokens
            pathLeft = extractPath tokensLeft
            pathRight = extractPath tokensRight
            newObj = nub $ [s | (s,_,_) <- pathLeft++pathRight, not (elem s n)]++[t | (_,t,_) <- pathLeft++pathRight, not (elem t n)]
            newMorph = nub [e | e <- pathLeft++pathRight, not (elem e a)]
    
    readLine :: String -> CG -> CG
    readLine line cg
        | null lexedLine = cg
        | elem Equals lexedLine = addCompositionLawEntry lexedLine cg
        | elem BeginArrow lexedLine = addMorphism lexedLine cg
        | otherwise = addObject lexedLine cg
        where
            lexedLine = (parserLex line)
    
    parseCGString :: String -> CG
    parseCGString str = newCG
        where
            ls = lines str
            cg = mkEmptyCompositionGraph
            newCG = foldr readLine cg ls
    
    -- | Reads a cg file and returns a composition graph.
    readCGFile :: String -> IO CG
    readCGFile path = do
        file <- readFile path
        return $ parseCGString file
        
    reversedRawPathToString :: (PrettyPrintable a, PrettyPrintable b) => RawPath a b -> String
    reversedRawPathToString [] = "<ID>"
    reversedRawPathToString [(s,t,l)] = pprint s ++ " -" ++ pprint l ++ "-> " ++ pprint t
    reversedRawPathToString ((s,t,l):xs) = pprint s ++ " -" ++ pprint l ++ "-> " ++ reversedRawPathToString xs
    
    unparseCG :: (PrettyPrintable a, PrettyPrintable b, Eq a, Eq b) => CompositionGraph a b -> String
    unparseCG cg = finalString
        where
            obString = intercalate "\n" $ pprint <$> ob cg
            arNotIdentity = filter (isNotIdentity cg) (genArrows cg)
            reversedRawPaths = (reverse.snd3.path) <$> arNotIdentity
            arStringBeforeComment = reversedRawPathToString <$> reversedRawPaths
            commentOutComposite = [if isComposite cg m then ('#':s) else s | (s,m) <- zip arStringBeforeComment arNotIdentity]
            arString = intercalate "\n" $ commentOutComposite
            lawString = intercalate "\n" $ (\(rp1,rp2) -> (reversedRawPathToString (reverse rp1)) ++ " = " ++ (reversedRawPathToString (reverse rp2))) <$> (law cg)
            finalString = "#Objects :\n"++obString++"\n\n# Arrows :\n"++arString++"\n\n# Composition law :\n"++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 cg filepath = do
        createDirectoryIfMissing True $ takeDirectory filepath
        writeFile filepath $ unparseCG cg