moduleDSLwhereimportControl.MonadimportControl.Applicative (pure, (<$>), (<*>))importData.MonoidimportData.List(sortBy, sort)importTest.QuickCheck -- not needed for the exam question -- Exam question code: empty :: Doc char :: Char -> Doc text :: String -> Doc line :: Doc -- newline (<>) :: Doc -> Doc -> Doc -- append union :: Doc -> Doc -> Doc -- a choice of two variants only differing in layout prettys :: Doc -> [String] d1 = union (text "x<-m") (text "x <- m") d2 = union (text "do {" <> d1 <> char ';' <> text "f x}") (text "do " <> d1 <> line <> text " f x" ) -- Task (a): ImplementationdataDoc = Empty | Char Char | Text String | Line | Concat Doc Doc | Union Doc Docderiving(Show, Eq) empty = Empty char = Char text = Text line = Line (<>) = Concat union = Union -- Note that lists form a Monad prettys (Empty) = return "" prettys (Char c) = return (c:[]) prettys (Text s) = return s prettys (Line) = return "\n" prettys (Concat x y) = sortBy cmp $ liftM2 (++) (prettys x) (prettys y) prettys (Union x y) = mergeOn width (prettys x) (prettys y) cmp :: String -> String -> Ordering cmp xs ys = compare (width xs) (width ys)typeWidth = Int width :: String -> Int width "" = 0 width s = maximum $ map length $ lines s mergeOn :: Ord a => (t -> a) -> [t] -> [t] -> [t] mergeOn f [] ys = ys mergeOn f xs [] = xs mergeOn f (x:xs) (y:ys) | f x <= f y = x:mergeOn f xs (y:ys) | otherwise = y:mergeOn f (x:xs) ys -- Task (b): Discussion {- Is your implementation deep or shallow? This implementation is deep. The constructors are trivial and the run function |prettys| is doing all of the work. Are you using any monads (explain)? The run function is using the list monad as a way of simulating a non-deterministic choice of several alternatives. Would some of the API operations fit the |Monoid| type class (explain)? It seems natural to have (Doc, empty, (<>)) as a Monoid. We just have to be careful with what equality means - for the above implementation with "derived" Eq the laws don't hold. One way around it is to use "smart" constructors instead - the smartapp below solves the first two monoid laws, but not the third. Another way is to compare the semantics. Then we don't need any smart constructors. Note that (Doc, empty, union) is not a Monoid although union is associative. This is because empty is an empty document, not an empty list of documents. Also, union is not really mathematical union, but cartesian product. -} --------- -- The rest is support code - not part of the expected exam answer.instanceMonoid Docwheremempty = empty mappend = smartapp smartapp Empty m = m smartapp m Empty = m smartapp m n = m <> n law1' (==) z (+) m = (z + m) == m law2' (==) z (+) m = (m + z) == m law3' (==) (+) m1 m2 m3 = ((m1 + m2) + m3) == (m1 + (m2 + m3)) law1 e = law1' e mempty mappend law2 e = law2' e mempty mappend law3 :: Monoid t2 => (t2 -> t2 -> Bool) -> t2 -> t2 -> t2 -> Bool law3 e = law3' e mappend synEq :: Doc -> Doc -> Bool synEq = (==) -- derived, syntactic equality semEq :: Doc -> Doc -> Bool semEq x y = prettys x `bagEq` prettys y bagEq x y = sort x == sort y -- The third monoid law does not hold for list equality. -- This is because the sortBy only sorts down to length, not in more detail.instanceArbitrary Docwherearbitrary = sized arbitraryDoc shrink = shrinkDoc arbitraryDoc :: Int -> Gen Doc arbitraryDoc n = oneof $ basecase ++ifn == 0then[]elserecursewherebasecase = [pure empty, char <$> arbitrary, text <$> arbitrary, pure line] recurse = [ (<>) <$> arbitrary <*> arbitrary , union <$> arbitrary <*> arbitrary ] shrinkDoc Empty = [] shrinkDoc (Char 'x') = [Empty] shrinkDoc (Char c) = [Empty, Char 'x'] shrinkDoc (Text s) = Empty:map Char s -- ++ map Text (shrink s) shrinkDoc Line = [Empty] shrinkDoc (Concat x y) = x:y:[Concat x' y | x' <- shrink x] ++ [Concat x y'| y' <- shrink y] shrinkDoc (Union x y) = x:y:[Union x' y | x' <- shrink x] ++ [Union x y'| y' <- shrink y] main =doquickCheck (law1 semEq) quickCheck (law2 semEq) quickCheck (law3 semEq) quickCheck (law1 synEq) quickCheck (law2 synEq) quickCheck (expectFailure $ law3 synEq) quickCheck (expectFailure $ law1' semEq empty union) quickCheck (expectFailure $ law2' semEq empty union) quickCheck (law3' semEq union) {- With list equality instead of bad equality, test3 is a simple test case that fails. *** Failed! Falsifiable (after 4 tests and 9 shrinks): -} test3 =letd1 = Union Empty Empty d2 = Union (Char 'x') Empty d3 = Union (Char 'y') Empty lhs = prettys $ (d1<>d2)<>d3 rhs = prettys $ d1<>(d2<>d3)in(law3 semEq d1 d2 d3, lhs, rhs)