Commit 6ebd43f4 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢
Browse files

Merge branch 'example-functor' into 'master'

Add functor implementation example

See merge request !19
parents 9557026f fa1fdbca
-- | An example functor implementation.
-- Implements the cross product `(AxB)`, which is already
-- implemented as a part of `Copar.Functors.Polynomial`.
{-# LANGUAGE TemplateHaskell #-}
module Copar.Functors.Pair (pair) where
import Text.Megaparsec
import Text.Show.Deriving (deriveShow1)
import qualified Data.Tuple as T
import qualified Data.Vector as V
import Copar.FunctorDescription
import Copar.RefinementInterface
import qualified Copar.Parser.Lexer as L
import Copar.Coalgebra.Parser
data Pair a = Pair a a
deriving (Show, Functor, Foldable, Traversable)
$(deriveShow1 ''Pair)
pair :: FunctorDescription Pair
pair = FunctorDescription
{ name = "Pair"
, syntaxExample = "{f, n} x PX"
, description = Just "A pair of functors"
, functorExprParser = pairp
pairp :: FunctorParser Pair
pairp = FunctorParser $ \inner ->
inner >>= \lhs -> try (do
rhs <- L.symbol "x" *> inner
return (Right (Pair lhs rhs))
) <|> return (Left lhs)
data Target = Small | Big | Other
deriving (Eq, Ord)
type instance F1 Pair = ()
type instance Label Pair = Bool
type instance Weight Pair = (Bool, Bool)
type instance F3 Pair = (Target, Target)
instance ParseMorphism Pair where
parseMorphismPoint (Pair lhs rhs) = (parsePair lhs rhs) >>= (\r -> return ((), r))
:: (Ord x)
=> (MorphParser l f1 x)
-> (MorphParser l f1 x)
-> MorphParser l f1 (V.Vector (x, Label Pair))
parsePair lhs rhs =
L.parens (do
l <- lhs
r <- L.comma *> rhs
return (V.fromList [(l, False), (r, True)])
instance RefinementInterface Pair where
init :: F1 Pair -> [Label Pair] -> Weight Pair
init _ _ = (True, True)
-- edges leading to the smaller block
:: [Label Pair]
-- weight of the previous block
-> Weight Pair
-- weight of smaller section, (rhs target block, lhs target block), weight of bigger section
-> (Weight Pair, F3 Pair, Weight Pair)
update [] weight = ((False, False), (if T.fst weight then Big else Other, if T.snd weight then Big else Other), weight)
update [True] weight = ((False, True), (Small, if T.snd weight then Big else Other), (fst weight, False))
update [False] weight = ((True, False), (if T.fst weight then Big else Other, Small), (False, snd weight))
-- This can't happen. We always use the smaller block for `update`,
-- which can at most have 1 of the 2 blocks in it.
update _ _ = undefined
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment