pyrites/haskell-experiments/src/Ologs.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
{-# HLINT ignore "Use concatMap" #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# HLINT ignore "Move catMaybes" #-}
{-# HLINT ignore "Use mapMaybe" #-}
{-# HLINT ignore "Use list comprehension" #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Ologs
  ( Arc,
    Identity,
    Olog,
    makeOlog,
    MakeOlogError (..),
  )
where

import Control.Monad
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Traversable

data Arc dot = Arc
  { name :: String,
    source :: dot,
    target :: dot
  }
  deriving (Show, Eq)

data Identity = Identity
  { lhs :: [String],
    rhs :: [String]
  }
  deriving (Show, Eq)

data Olog dot = Olog
  { dots :: [dot],
    arcs :: [Arc dot],
    identities :: [Identity]
  }
  deriving (Show, Eq)

-- type f $ x = f x
-- type ($) f x = f x

data MakeOlogError dot
  = UnknownSource String dot
  | UnknownTarget String dot
  | ForbiddenTrivialIdentity
  | UnknownArc String
  | NonJoiningExpressionLhs [String]
  | NonJoiningExpressionRhs [String]
  | IdentityMismatch [String] [String] (dot, dot) (dot, dot)
  | NotALoop [String]
  deriving (Show, Eq)

makeOlog ::
  forall dot.
  (Eq dot) =>
  [dot] ->
  [(String, dot, dot)] ->
  [([String], [String])] ->
  Either (MakeOlogError dot) (Olog dot)
makeOlog dots preArcs preIdentities = do
  arcs <- for preArcs \(name, source, target) -> do
    -- TODO reuse `namesToArcs`?
    unless (source `elem` dots) $ Left $ UnknownSource name source
    unless (target `elem` dots) $ Left $ UnknownTarget name target
    pure Arc{name, source, target}
  identities <- for preIdentities \(lhs, rhs) -> do
    lhs' :: [(String, (dot, dot))] <- for lhs \arcName -> case Map.lookup arcName namesToArcs of
      Nothing -> Left $ UnknownArc arcName
      Just srcAndTgt -> pure (arcName, srcAndTgt)
    rhs' :: [(String, (dot, dot))] <- for rhs \arcName -> case Map.lookup arcName namesToArcs of
      Nothing -> Left $ UnknownArc arcName
      Just srcAndTgt -> pure (arcName, srcAndTgt)
    case (nonEmpty lhs', nonEmpty rhs') of
      (Nothing, Nothing) ->
        Left ForbiddenTrivialIdentity
      (Just l, Nothing) -> do
        checkTerm NonJoiningExpressionLhs l
        let (_, (_, tgt)) = NE.head l
        let (_, (src, _)) = NE.last l
        errorWhen (src /= tgt) $ NotALoop lhs
      (Nothing, Just r) -> do
        checkTerm NonJoiningExpressionRhs r
        let (_, (_, tgt)) = NE.head r
        let (_, (src, _)) = NE.last r
        errorWhen (src /= tgt) $ NotALoop rhs
      (Just l, Just r) -> do
        checkTerm NonJoiningExpressionLhs l
        checkTerm NonJoiningExpressionRhs r
        let combinedSrcTgt xhs = (fst $ snd $ NE.last xhs, snd $ snd $ NE.head xhs)
            l' = combinedSrcTgt l
            r' = combinedSrcTgt r
        errorWhen (l' /=  r') $ IdentityMismatch lhs rhs l' r'
    pure Identity {lhs, rhs}
  pure Olog {dots, arcs, identities}
  where
    checkTerm errorFactory arcs = do
      let
        targets = NE.tail $ snd . snd <$> (arcs :: (NonEmpty (String, (dot, dot))))
        sources = NE.init $ fst . snd <$> arcs
      errorWhen (sources /= targets) $ errorFactory $ map fst $ NE.toList arcs 
    errorWhen b e = if b then Left e else Right ()
    namesToArcs = Map.fromList $ (\(name, src, tgt) -> (name, (src, tgt))) <$> preArcs