UnionExercise.hs

#!/usr/bin/env stack
-- stack --resolver=lts-8.11 script --package=union
{-# OPTIONS -Wall -Werror #-}

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeOperators     #-}

import           Data.Functor.Identity (Identity (..), runIdentity)
import           Data.Union            (OpenUnion, Union (That, This),
                                        absurdUnion, union)

data OpL1 = Add | Sub | Neg
    deriving (Bounded, Enum, Show)

data OpL2 = Mul | Div | Exp
    deriving (Bounded, Enum, Show)

type Op = OpenUnion '[OpL1, OpL2]

data CallAdd = CallAdd{caX :: Int, caY :: Int}
data CallSub = CallSub{csX :: Int, csY :: Int}
data CallNeg = CallNeg{cnX :: Int}

type CallL1 = OpenUnion '[CallAdd, CallSub, CallNeg]

data CallMul = CallMul{cmX :: Int, cmY :: Int}
data CallDiv = CallDiv{cdX :: Int, cdY :: Int}
data CallExp = CallExp{ceX :: Int}

type CallL2 = OpenUnion '[CallMul, CallDiv, CallExp]

type Call = OpenUnion '[CallL1, CallL2]

sampleOp :: [Op]
sampleOp =
    map (This . Identity) sampleOpL1 ++
    map (That . This . Identity) sampleOpL2
  where
    sampleOpL1 = [Add, Sub, Neg]
    sampleOpL2 = [Mul, Div, Exp]

sampleCall :: [Call]
sampleCall =
    map ti sampleCallL1 ++
    map tti sampleCallL2
  where
    ti = This . Identity
    tti = That . This . Identity
    ttti = That . That . This . Identity
    sampleCallL1 =
        map ti sampleCallAdd ++ map tti sampleCallSub ++ map ttti sampleCallNeg
    sampleCallL2 =
        map ti sampleCallMul ++ map tti sampleCallDiv ++ map ttti sampleCallExp
    sampleCallAdd = [CallAdd 1 2]
    sampleCallDiv = [CallDiv 3 4]
    sampleCallExp = [CallExp 5]
    sampleCallMul = [CallMul 6 7]
    sampleCallNeg = [CallNeg 8]
    sampleCallSub = [CallSub 9 0]

prettyOp :: Op -> String
prettyOp =
    foldOpenUnion2
        (\case Add -> "_+_"; Sub -> "_-_"; Neg -> "-_")
        (\case Mul -> "_*_"; Div -> "_/_"; Exp -> "e_")

prettyCall :: Call -> String
prettyCall =
    foldOpenUnion2
        (foldOpenUnion3
            (\CallAdd{caX, caY} -> show caX ++ " + " ++ show caY)
            (\CallSub{csX, csY} -> show csX ++ " - " ++ show csY)
            (\CallNeg{cnX} -> "- " ++ show cnX))
        (foldOpenUnion3
            (\CallMul{cmX, cmY} -> show cmX ++ " * " ++ show cmY)
            (\CallDiv{cdX, cdY} -> show cdX ++ " / " ++ show cdY)
            (\CallExp{ceX} -> "e ^ " ++ show ceX))

foldUnion2 :: (f a -> x) -> (f b -> x) -> Union f '[a, b] -> x
foldUnion2 f1 f2 = absurdUnion `union` f2 `union` f1

foldUnion3 :: (f a -> x) -> (f b -> x) -> (f c -> x) -> Union f '[a, b, c] -> x
foldUnion3 f1 f2 f3 = absurdUnion `union` f3 `union` f2 `union` f1

foldOpenUnion2 :: (a -> x) -> (b -> x) -> OpenUnion '[a, b] -> x
foldOpenUnion2 f1 f2 = foldUnion2 (f1 . runIdentity) (f2 . runIdentity)

foldOpenUnion3 :: (a -> x) -> (b -> x) -> (c -> x) -> OpenUnion '[a, b, c] -> x
foldOpenUnion3 f1 f2 f3 =
    foldUnion3 (f1 . runIdentity) (f2 . runIdentity) (f3 . runIdentity)

main :: IO ()
main = putStrLn . unlines . map prettyCall $ sampleCall