Metalanguage.purs

module Metalanguage where

import Prelude

import Data.Array as Array
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence, traverse)

data Value = ScalarValue String | VectorValue (Array Value)
data Sization = NonEmpty | Any
derive instance eqSization :: Eq Sization
derive instance ordSization :: Ord Sization

data BasicSubsetF a
  = Singleton String
  | AnyScalar Sization
  | ListOf Sization a
  | ListLike (Array a)

newtype BasicSubset = BasicSubset (BasicSubsetF BasicSubset)
data Subset
  = Basic (BasicSubsetF Subset)
  | Union Subset

singleton :: Value -> BasicSubset
singleton = BasicSubset <<< case _ of
  ScalarValue s -> Singleton s
  VectorValue vs -> ListLike (singleton <$> vs)

demonstrate :: BasicSubset -> Value
demonstrate (BasicSubset bs) = case bs of
  Singleton s -> ScalarValue s
  AnyScalar Any -> ScalarValue ""
  AnyScalar NonEmpty -> ScalarValue "0"
  ListOf Any _ -> VectorValue []
  ListOf NonEmpty bs' -> VectorValue [demonstrate bs']
  ListLike vs -> VectorValue (demonstrate <$> vs)

overlap :: BasicSubset -> BasicSubset -> Maybe BasicSubset
overlap = case _, _ of
  BasicSubset s1, BasicSubset s2 -> BasicSubset <$> case s1, s2 of
    Singleton v1, Singleton v2 ->
      if v1 == v2 then Just (Singleton v1) else Nothing
    Singleton "", AnyScalar Any -> Just (Singleton "")
    AnyScalar Any, Singleton "" -> Just (Singleton "")
    Singleton "", AnyScalar NonEmpty -> Nothing
    AnyScalar NonEmpty, Singleton "" -> Nothing
    AnyScalar _, Singleton s -> Just (Singleton s)
    Singleton s, AnyScalar _ -> Just (Singleton s)
    AnyScalar z1, AnyScalar z2 -> Just $ AnyScalar (min z1 z2)

    Singleton _, ListOf _ _ -> Nothing
    ListOf _ _, Singleton _ -> Nothing
    Singleton _, ListLike _ -> Nothing
    ListLike _, Singleton _ -> Nothing
    AnyScalar _, ListOf _ _ -> Nothing
    ListOf _ _, AnyScalar _ -> Nothing
    AnyScalar _, ListLike _ -> Nothing
    ListLike _, AnyScalar _ -> Nothing

    ListOf NonEmpty _, ListLike [] -> Nothing
    ListLike [], ListOf NonEmpty _ -> Nothing
    ListOf _ p_, ListLike ps ->
      ListLike <$> traverse (overlap p_) ps
    ListLike ps, ListOf _ p_ ->
      ListLike <$> traverse (flip overlap p_) ps

    ListOf z1 p1_, ListOf z2 p2_ ->
      ListOf (min z1 z2) <$> overlap p1_ p2_
    ListLike ps1, ListLike ps2 ->
      if Array.length ps1 == Array.length ps2
      then ListLike <$> sequence (Array.zipWith overlap ps1 ps2)
      else Nothing