SafeCompositionGraphFunctor.hs

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

A parser to read .fscg files.

A .fscg file follows the following rules :
    1. There is a line "<SRC>" and a line "</SRC>".
    1.1 Between these two lines, the source safe composition graph is defined as in a scg file.
    2. There is a line "<TGT>" and a line "</TGT>".
    2.1 Between these two lines, the target safe composition graph is defined as in a scg file.
    3. Outside of the two previously described sections, you can declare the maps between objects and morphisms.
    3.1 You map an object to another with the following syntax : "object1 => object2".
    3.2 You map a morphism to another with the following syntax : "objSrc1 -arrowSrc1-> objSrc2 => objTgt1 -arrowTgt1-> objTgt2".
    4. You don't have to (and you shouldn't) specify maps from identities, nor maps from composite arrows.
-}

module IO.Parsers.SafeCompositionGraphFunctor
(
    readFSCGFile
)
where
    import FiniteCategory.FiniteCategory
    import Cat.PartialFinCat
    import CompositionGraph.CompositionGraph
    import CompositionGraph.SafeCompositionGraph
    import IO.Parsers.Lexer
    import IO.Parsers.SafeCompositionGraph
    import Data.IORef
    import Data.Text (Text, pack, unpack)
    import Data.List (elemIndex, nub, intercalate)
    import Utils.Tuple
    import IO.PrettyPrint
    import Utils.AssociationList
    import Diagram.Diagram
        
    import System.Directory (createDirectoryIfMissing)
    import System.FilePath.Posix (takeDirectory)
    
    type SCGF = PartialFunctor SCG (SCGMorphism Text Text) Text
    type SCGD = Diagram SCG (SCGMorphism Text Text) Text SCG (SCGMorphism Text Text) Text
    
    addOMapEntry :: [Token] -> SCGF -> SCGF
    addOMapEntry [Name x, MapsTo, Name y] pf
        | elem x (keys (omapPF pf)) = if y == ((omapPF pf) !-! x) then pf else error ("Incoherent maps of object : F("++show x++") = "++show y ++ " and "++show ((omapPF pf) !-! x))
        | otherwise = PartialFunctor{srcPF=srcPF pf, tgtPF=tgtPF pf, omapPF=((x,y):(omapPF pf)), mmapPF=mmapPF pf}
    addOMapEntry otherTokens _ = error $ "addOMapEntry on invalid tokens : "++show otherTokens
    
    addMMapEntry :: [Token] -> SCGF -> SCGF
    addMMapEntry tks@[Name sx, BeginArrow, Name lx, EndArrow, Name tx, MapsTo, Identity] pf = if elem sx (keys (omapPF pf)) then PartialFunctor{srcPF=srcPF pf, tgtPF=tgtPF pf, omapPF=omapPF pf, mmapPF=((sourceMorph,(identity (target pf) ((omapPF pf) !-! sx))):(mmapPF pf))} else error ("You must specify the image of the source of the morphism before mapping to an identity : "++show tks)
        where
            sourceMorphCand = filter (\e -> getLabelS e == Just lx) (genAr (source pf) sx tx)
            sourceMorph = if null sourceMorphCand then error $ "addMMapEntry : morphism not found in source category for the following map : "++ show tks else head sourceMorphCand
    addMMapEntry tks@[Name sx, BeginArrow, Name lx, EndArrow, Name tx, MapsTo, Name sy, BeginArrow, Name ly, EndArrow, Name ty] pf = PartialFunctor{srcPF=srcPF newPF2, tgtPF=tgtPF newPF2, omapPF=omapPF newPF2, mmapPF=((sourceMorph,targetMorph):(mmapPF newPF2))}
        where
            sourceMorphCand = filter (\e -> getLabelS e == Just lx) (genAr (source pf) sx tx)
            targetMorphCand = filter (\e -> getLabelS e == Just ly) (genAr (target pf) sy ty)
            sourceMorph = if null sourceMorphCand then error $ "addMMapEntry : morphism not found in source category for the following map : "++ show tks else head sourceMorphCand
            targetMorph = if null targetMorphCand then error $ "addMMapEntry : morphism not found in target category for the following map : "++ show tks else head targetMorphCand
            newPF1 = addOMapEntry [Name sx, MapsTo, Name sy] pf
            newPF2 = addOMapEntry [Name tx, MapsTo, Name ty] newPF1
            
    addMMapEntry otherTokens _ = error $ "addMMapEntry on invalid tokens : "++show otherTokens
    
    readLineF :: String -> SCGF -> SCGF
    readLineF line pf@PartialFunctor{srcPF=s, tgtPF=t, omapPF=om, mmapPF=mm}
        | null lexedLine = pf
        | elem MapsTo lexedLine = if elem BeginArrow lexedLine
            then addMMapEntry lexedLine pf
            else addOMapEntry lexedLine pf
        | otherwise = pf
        where
            lexedLine = (parserLex line)

    extractSrcSection :: [String] -> [String]
    extractSrcSection lines
        | not (elem [BeginSrc] (parserLex <$> lines)) = error $ "No <SRC> section or malformed <SRC> section in file : "++ show lines
        | not (elem [EndSrc] (parserLex <$> lines)) = error $ "No <SRC> section or malformed <SRC> section in file : "++ show lines
        | indexEndSrc < indexBeginSrc = error $ "Malformed <SRC> section in file : "++ show lines
        | otherwise = c
        where
            Just indexBeginSrc = (elemIndex [BeginSrc] (parserLex <$> lines))
            Just indexEndSrc = (elemIndex [EndSrc] (parserLex <$> lines))
            (a,b) = splitAt (indexBeginSrc+1) lines
            (c,d) = splitAt (indexEndSrc-indexBeginSrc-1) b
            
    extractTgtSection :: [String] -> [String]
    extractTgtSection lines
        | not (elem [BeginTgt] (parserLex <$> lines)) = error $ "No <TGT> section or malformed <TGT> section in file : "++ show lines
        | not (elem [EndTgt] (parserLex <$> lines)) = error $ "No <TGT> section or malformed <TGT> section in file : "++ show lines
        | indexEndTgt < indexBeginTgt = error $ "Malformed <TGT> section in file : "++ show lines
        | otherwise = c
        where
            Just indexBeginTgt = (elemIndex [BeginTgt] (parserLex <$> lines))
            Just indexEndTgt = (elemIndex [EndTgt] (parserLex <$> lines))
            (a,b) = splitAt (indexBeginTgt+1) lines
            (c,d) = splitAt (indexEndTgt-indexBeginTgt-1) b
    
    rawreadFSCGFile :: String -> IO SCGF
    rawreadFSCGFile path = do
        file <- readFile path
        let ls = filter (not.null.parserLex) $ lines file
        let src = parseSCGString $ intercalate "\n" (extractSrcSection ls)
        let tgt = parseSCGString $ intercalate "\n" (extractTgtSection ls)
        let pf = PartialFunctor{srcPF=src, tgtPF=tgt,omapPF=[], mmapPF=[]}
        let finalPF = foldr readLineF pf ls
        return finalPF
    
    -- | Reads a fscg file and completes everything so that it becomes a diagram.
    completeFSCG :: SCGF -> SCGD
    completeFSCG pf@PartialFunctor{srcPF=s, tgtPF=t, omapPF=om, mmapPF=mm} =
        Diagram{src=s, tgt=t, omap=om, mmap=completeMmap s t om mm}
        
    -- | Reads a fscg file and returns a diagram.
    readFSCGFile :: String -> IO SCGD
    readFSCGFile path = do
        raw <- rawreadFSCGFile path
        return (completeFSCG raw)