pandora_brackets.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import "base" Prelude (Char, Int, Show (show), (++), print, succ)

import "pandora" Pandora.Core.Functor
import "pandora" Pandora.Core.Morphism
import "pandora" Pandora.Pattern.Object
import "pandora" Pandora.Pattern.Functor
import "pandora" Pandora.Paradigm.Basis
import "pandora" Pandora.Paradigm.Junction
import "pandora" Pandora.Paradigm.Inventory
import "pandora" Pandora.Paradigm.Structure



data Shape = Opened | Closed

data Style = Round | Square | Angle | Curly

instance Setoid Style where
	Round == Round = True
	Square == Square = True
	Angle == Angle = True
	Curly == Curly = True
	_ == _ = False

data Symbol = Bracket Style Shape | Character

type Indexed a = Int :*: a

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

index :: a -> Stateful Int :.: Indexed >< a
index x = modify succ *> ((:*:) ? x <$> get)

type Symbols = Stack Symbol
type Styles = Stack Style

type family Numbered stack where
	Numbered (Stack Symbol) = Stack (Indexed Symbol)
	Numbered (Stack Style) = Stack (Indexed Style)

pattern Skip <- n :*: Character
pattern Start n style = n :*: Bracket style Opened
pattern Finish n style = n :*: Bracket style Closed

checking :: Numbered Symbols -> Conclusion Stumble ()
checking struct = result >>= maybe (Success ()) logjam . composition where

	result :: Conclusion Stumble >< Numbered Styles
	result = attached <$> composition (struct ->> proceed) empty

	logjam :: Nonempty Stack (Indexed Style) -> Conclusion Stumble ()
	logjam = Failure . Logjam . extract

-- If it's not a bracket, just skip it
-- If it's opened bracket, add it to the stack
-- If it's closed bracket, get the last style of bracket and match
proceed :: Indexed Symbol -> Stateful (Numbered Styles) :> Conclusion Stumble >< ()
proceed Skip = point ()
proceed (Start n opened) = equip . modify . push $ n :*: opened
proceed (Finish n closed) = top <$> equip get >>= maybe deadend match where

	deadend :: Stateful (Numbered Styles) :> Conclusion Stumble >< ()
	deadend = lay . Failure . Deadend $ n :*: closed

	-- Match opened bracket from state with current closed one
	match :: Indexed Style -> Stateful (Numbered Styles) :> Conclusion Stumble >< ()
	match (m :*: opened) = closed /= opened & ifelse mismatch (equip $ modify pop) where

		mismatch :: Stateful (Numbered Styles) :> Conclusion Stumble >< ()
		mismatch = lay . Failure $ Mismatch (m :*: opened) (n :*: closed)

indexing :: Symbols -> Numbered Symbols
indexing struct = extract . statefully 0 $ struct ->> index



instance Show Symbol where
	show Character = "_"
	show (Bracket Round Opened) = "("
	show (Bracket Round Closed) = ")"
	show (Bracket Square Opened) = "["
	show (Bracket Square Closed) = "]"
	show (Bracket Angle Opened) = "<"
	show (Bracket Angle Closed) = ">"
	show (Bracket Curly Opened) = "{"
	show (Bracket Curly Closed) = "}"

recognize :: Char -> Symbol
recognize '(' = Bracket Round Opened
recognize ')' = Bracket Round Closed
recognize '[' = Bracket Square Opened
recognize ']' = Bracket Square Closed
recognize '<' = Bracket Angle Opened
recognize '>' = Bracket Angle Closed
recognize '{' = Bracket Curly Opened
recognize '}' = Bracket Curly Closed
recognize _ = Character

instance Show Stumble where
	show (Deadend (n :*: closed)) = "Unexpectedly closed: " ++
		"#" ++ show n ++ " " ++ show (Bracket closed Closed)
	show (Logjam (n :*: closed)) = "Unexpectedly opened: " ++
		"#" ++ show n ++ " " ++ show (Bracket closed Opened)
	show (Mismatch (n :*: opened) (m :*: closed)) = "Mismatching brackets: " ++
		"#" ++ show n ++ " " ++ show (Bracket opened Opened) ++ " and " ++
		"#" ++ show m ++ " " ++ show (Bracket closed Closed)

example :: Stack Char
example = push '{' $ push ']' $ empty

main = conclusion print print . checking . indexing $ recognize <$> example