joint_brackets.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import Control.Joint.Core (type (:=))
import Control.Joint.Composition (run)
import Control.Joint.Transformer (build, embed, type (:>))
import Control.Joint.Base.State (State, get, put, modify)

data Shape = Opened | Closed
	deriving (Eq, Show)

data Style = Round | Square | Angle | Curly
	deriving (Eq, Show)

data Symbol = Nevermind | Bracket Style Shape
	deriving Show

data Stumble
	-- Closed bracket without opened one
	= Deadend (Int, Style)
	-- Opened bracket without closed one
	| Logjam (Int, Style)
	-- Closed bracket doesn't match opened one
	| Mismatch (Int, Style) (Int, Style)
	deriving Show

checking :: [(Int, Symbol)] -> Either Stumble ()
checking struct = run (traverse proceed struct) [] >>= \case
	(s : _, _) -> Left . Logjam $ s where
	([], _) -> Right ()

proceed :: (Int, Symbol) -> State [(Int, Style)] :> Either Stumble := ()
proceed (_, Nevermind) = pure ()
proceed (n, Bracket style Opened) = build . modify . (:) $ (n, style)
procceed (n, Bracket closed Closed) = build get >>= \case
	[] -> embed $ Left . Deadend $ (n, closed)
	((m, opened) : ss) -> if closed /= opened
		then embed mismatch else build $ put ss where

		mismatch :: Either Stumble ()
		mismatch = Left $ Mismatch (m, opened) (n, closed)

indexing :: [Symbol] -> [(Int, Symbol)]
indexing ss = zip [1..] ss

example_ok, example_mismatch, example_deadend, example_logjam :: [Symbol]
example_ok = Bracket Curly Opened : Nevermind : Bracket Curly Closed : [] -- {x}
example_mismatch = Bracket Curly Opened : Bracket Square Closed : [] -- {]
example_deadend = Bracket Round Closed : [] -- )
example_logjam = Bracket Angle Opened : [] -- <

main = either print print . checking . indexing $ example_logjam