Hi, I'm working on a version of Simon Thompson's code from "The Craft of Functional programming" to handle polymorhpic data types. Heres the question Im working on - Ive tried doing the first part, but i would really apprecate it if someone could let me know if ive implemented it wrong. Mike import "Hugs.Prelude"; import Monad; import System; import Control.Monad.Error; import Char; {------------------------------------------------------------------------------ USEFUL AUXILIARY CONSTRUCTS ------------------------------------------------------------------------------} list2set :: Eq a => [a] -> [a] list2set [] = [] list2set (x:xs) | x `elem` xs = list2set xs | otherwise = x : list2set xs inBrackets :: String -> String inBrackets str = "(" ++ str ++ ")" inBrackets2 :: String -> String -> String inBrackets2 [] s2 = s2 inBrackets2 s1 [] = s1 inBrackets2 s1 s2 = inBrackets (s1 ++ " " ++ s2) joinStrings :: String -> [String] -> String joinStrings _ [] = "" joinStrings _ [s] = s joinStrings sep (s:ss) = s ++ sep ++ joinStrings sep ss char2str :: Char -> String char2str x = [x] dig2int :: Char -> Int dig2int d = fromEnum d - fromEnum '0' str2int :: String -> Int str2int s = str2intAux (reverse s) where str2intAux [x] = dig2int x str2intAux (x:xs) = dig2int x + 10*(str2intAux xs) {------------------------------------------------------------------------------ PARSING / PATTERN MATCHING Code based on Thompson, Section 17.5 ------------------------------------------------------------------------------} infixr 5 >*> type Parse a b = [a] -> [(b,[a])] -- Don't match anything matchNone :: Parse a b matchNone inp = [] -- Add a symbol into the stream and assert match matchAndAdd :: b -> Parse a b matchAndAdd val inp = [(val,inp)] -- Match if next input satisfies a given property matchProperty :: (a -> Bool) -> Parse a a matchProperty p (x:xs) | p x = [(x,xs)] | otherwise = [] matchProperty _ [] = [] -- Match the next input symbol matchInput :: Eq a => a -> Parse a a matchInput t = matchProperty (t==) -- combine the results of two matchs -- e.g. (matchLP `alt` matchDigit) checks for an LP or a digit alt :: (Eq a, Eq b) => Parse a b -> Parse a b -> Parse a b alt p1 p2 inp = list2set (p1 inp ++ p2 inp) -- Chain matches together to recognise strings (>*>) :: Parse a b -> Parse a c -> Parse a (b,c) (>*>) p1 p2 inp = [((y,z),rem2) | (y,rem1) <- p1 inp, (z,rem2) <- p2 rem1 ] -- Build values from matchd strings build :: Parse a b -> (b -> c) -> Parse a c build p f inp = [ (f x, rem) | (x, rem) <- p inp ] -- Match a list of symbols all satisfying the same property matchList :: (Eq a, Eq b) => Parse a b -> Parse a [b] matchList p = (matchAndAdd []) `alt` ((p >*> matchList p) `build` (uncurry (:))) -- Match a single symbols satisfying a property lift :: (Eq a, Eq b) => Parse a b -> Parse a [b] lift p = (p >*> matchAndAdd []) `build` (uncurry (:)) -- Match a non-empty list of symbols all satifying the same property matchNEList :: (Eq a, Eq b) => Parse a b -> Parse a [b] matchNEList p = (p >*> matchList p) `build` (uncurry (:)) -- Match an alphanumeric string of characters matchAlphaNums :: Parse Char [Char] matchAlphaNums = matchList matchAlphaNum -- Match a non-empty string of inputs, one after the other matchInputs :: Eq a => [a] -> Parse a [a] matchInputs [] = error "matchInputs: Empty test string" matchInputs [x] = matchInput x `build` buildMatch1 where buildMatch1 x = [x] matchInputs (x:xs) = (matchInput x >*> matchInputs xs) `build` (uncurry (:)) where buildMatch2 (x,y) = [x,y] {------------------------------------------------------------------------------ PARTICULAR TOKENS OF INTEREST ------------------------------------------------------------------------------} matchLP = matchInput '(' -- left parenthesis matchRP = matchInput ')' -- right parenthesis matchCO = matchInput ',' -- comma matchSP = matchInput ' ' -- space matchLB = matchInput '[' -- left bracket matchRB = matchInput ']' -- right bracket matchPT = matchInput '.' -- point (dot) matchSQ = matchInput '\'' -- single quote matchDQ = matchInput '"' -- double quote matchSL = matchInput '\\' -- slash matchAny = matchProperty (\_ -> True) matchAlphaNum = matchProperty isAlphaNum matchUpper = matchProperty isUpper matchLower = matchProperty isLower matchDigit = matchProperty isDigit matchWhiteSpace = matchList matchSP matchArrow = (matchWhiteSpace >*> matchInputs "->" >*> matchWhiteSpace) `build` buildArrow where buildArrow _ = "->" matchInt = matchNEList matchDigit matchFloat = (matchInt >*> matchPT >*> matchInt) `build` buildFloat where buildFloat (x,(_,y)) = (x ++ "." ++ y) matchChar = (matchSQ >*> ((matchInputs "\\'" ) `alt` ((matchProperty ('\'' /=)) `build` char2str)) >*> matchSQ) `build` buildChar where buildChar (_,(s,_)) = "'" ++ s ++ "'" matchString = (matchDQ >*> matchList ((matchInputs "\\\"" ) `alt` ((matchProperty ('"' /=)) `build` char2str)) >*> matchDQ) `build` buildString where buildString (_,(ss,_)) = "\"" ++ (foldr (++) "" ss) ++ "\"" matchBool = (matchInputs "True") `alt` (matchInputs "False") {------------------------------------------------------------------------------ PARSING TYPES ------------------------------------------------------------------------------} type TypeName = String type TypeNameParser = Parse Char TypeName matchTypeName :: TypeNameParser matchTypeName = (matchUpper >*> matchAlphaNums) `build` (uncurry (:)) type TypeParser = Parse Char Type {------------added PolyT ----------------------------------------------} data Type = NullT | UnaryT TypeName | ListT Type | TupleT [Type] | FuncT Type Type | PolyT Type Type deriving (Show) instance Eq Type where NullT == NullT = True UnaryT s == UnaryT t = s == t ListT s == ListT t = s == t TupleT s == TupleT t = s == t FuncT u v == FuncT x y = (u == x) && (v == y) UnaryT s == TupleT [t] = UnaryT s == t UnaryT s == FuncT NullT t = UnaryT s == t _ == _ = False --PolyT a b == PolyT x y = (a==x) || (b == y) PolyT a b == PolyT x y = polyT x y normalise :: Type -> Type normalise (TupleT []) = NullT normalise (TupleT [t]) = normalise t normalise (FuncT _ NullT) = NullT normalise (FuncT NullT t) = normalise t normalise (ListT t) = ListT (normalise t) normalise t = t {--------------------- Question One parts -----------------------------} {-----------define new type VarName to represent polymorphic types---} type VarParse a b = [a]->b {--------------- recognise characters like a, b ---------------------} varParse:: Parse Char Expr varParse = spot isVar 'build' Var isVar :: Char->Bool isVar x = ('a' <= x && x <= 'z') {--------------- polymorhpic function -------------------------------} polyT :: (a -> c) -> (b -> c) -> Either a b -> c polyT a b = either a b {--------------- Polymorphic data matching -------------------------} matchType :: TypeParser matchType = matchUnaryT `alt` matchListT `alt` matchTupleT `alt` matchFuncT `alt` matchNullT `alt` matchPolyT matchPolyT :: TypeParser matchPolyT = (matchLP >*> matchPolyT >*> matchRP) `build` buildPolyT where buildPolyT (_,(t,_)) = normalise t -------------------------------------------------------- matchNullT :: TypeParser matchNullT = (matchLP >*> matchWhiteSpace >*> matchRP) `build` (\_ -> NullT) matchUnaryT :: TypeParser matchUnaryT str = [ (UnaryT s, rem) | (s,rem) <- matchTypeName str ] matchListT = (matchLB >*> matchWhiteSpace >*> matchType >*> matchWhiteSpace >*> matchRB) `build` buildListT where buildListT (_,(_,(t,(_,_)))) = t matchTupleT = (matchLP >*> matchType >*> matchRepeatingBlock >*> matchRP) `build` buildTupleT where matchBlock = matchCO >*> matchWhiteSpace >*> matchType matchRepeatingBlock = matchList matchBlock buildTupleT (_,(t,(blocks,_))) = normalise typ where typ = TupleT (t : (map getTypes blocks)) getTypes (_,(_,x)) = x matchFuncT :: TypeParser matchFuncT = matchFuncNoBracketsT `alt` matchFuncInBracketsT matchFuncInBracketsT :: TypeParser matchFuncInBracketsT = (matchLP >*> matchFuncT >*> matchRP) `build` buildFuncIBT where buildFuncIBT (_,(t,_)) = normalise t matchFuncNoBracketsT :: TypeParser matchFuncNoBracketsT = ( (matchUnaryT `alt` matchTupleT `alt` matchFuncInBracketsT `alt` matchNullT)
*> matchArrow >*> matchType ) `build` buildFuncNBT where buildFuncNBT (t1,(_,t2)) = normalise (FuncT t1 t2)
{------------------------------------------------------------------------------ TYPE GENERATED BY FUNCTION APPLICATION ------------------------------------------------------------------------------} doApplicationT :: Type -> Type -> Type doApplicationT t1 t2 | t2 == getFst t1 = getSnd t1 | otherwise = NullT where getFst (FuncT x _) = x getFst _ = NullT getSnd (FuncT _ y) = y getSnd _ = NullT {------------------------------------------------------------------------------ PARSING EXPRESSIONS ------------------------------------------------------------------------------} type FuncName = String type ExprParser = Parse Char Expr data Expr = NullE | FuncE FuncName | IntE Int | FloatE Float | CharE Char | StringE String | BoolE Bool | ListE [Expr] | TupleE [Expr] | ApplyE [Expr] deriving (Eq, Show) matchExpr :: ExprParser matchExpr = matchNotNullE `alt` matchNullE matchNotNullE :: ExprParser matchNotNullE = matchNotNullOrApplyE `alt` matchApplyE matchNotNullOrApplyE :: ExprParser matchNotNullOrApplyE = matchFuncE `alt` matchIntE `alt` matchFloatE `alt` matchCharE `alt` matchStringE `alt` matchBoolE `alt` matchListE `alt` matchTupleE matchNullE :: ExprParser matchNullE = (matchLP >*> matchWhiteSpace >*> matchRP) `build` (\_ -> NullE) matchFuncE :: ExprParser matchFuncE = ((matchLower >*> matchAlphaNums) `build` (FuncE . (uncurry (:)))) matchIntE :: ExprParser matchIntE = matchInt `build` (IntE . read) matchFloatE :: ExprParser matchFloatE = matchFloat `build` (FloatE . read) matchCharE :: ExprParser matchCharE = matchChar `build` (CharE . read) matchStringE :: ExprParser matchStringE = matchString `build` (StringE . read) matchBoolE :: ExprParser matchBoolE = matchBool `build` (BoolE . read) matchListE = (matchLB >*> matchWhiteSpace >*> matchExpr >*> matchWhiteSpace >*> matchBlock >*> matchRB) `build` buildListE where buildListE :: (Char,([Char],(Expr,([Char],([Expr],Char))))) -> Expr buildListE (_,(_,(e,(_,(es,_))))) = ListE (e:es) matchBlock = matchList matchComponent matchComponent = (matchCO >*> matchWhiteSpace >*> matchExpr >*> matchWhiteSpace) `build` buildComponent buildComponent :: (Char,(String,(Expr,String))) -> Expr buildComponent (_,(_,(e,_))) = e matchTupleE = (matchLP >*> matchWhiteSpace >*> matchExpr >*> matchWhiteSpace >*> matchBlock >*> matchRP) `build` buildTupleE where buildTupleE :: (Char,([Char],(Expr,([Char],([Expr],Char))))) -> Expr buildTupleE (_,(_,(e,(_,(es,_))))) = TupleE (e:es) matchBlock = matchList matchComponent matchComponent = (matchCO >*> matchWhiteSpace >*> matchExpr >*> matchWhiteSpace) `build` buildComponent buildComponent :: (Char,(String,(Expr,String))) -> Expr buildComponent (_,(_,(e,_))) = e matchApplyE = (matchNotNullOrApplyE >*> matchRepeatingBlock) `build` buildApplyE where matchRepeatingBlock = matchList (matchSP >*> matchWhiteSpace >*> matchExpr) buildApplyE :: (Expr,[(Char,(String,Expr))]) -> Expr buildApplyE (e,xs) = ApplyE (e : map third xs) third :: (Char,(String,Expr)) -> Expr third (_,(_,e)) = e {------------------------------------------------------------------------------ DECLARING TYPES OF USER-SPECIFIED FUNCTIONS ------------------------------------------------------------------------------} data Declaration = NullD | Declare Expr Type deriving (Eq, Show) type DeclarationParser = Parse Char Declaration matchDeclaration = (matchExpr >*> matchWhiteSpace >*> matchInputs "::" >*> matchWhiteSpace >*> matchType) `build` buildDeclaration where buildDeclaration (e,(_,(_,(_,t)))) = Declare e t declare :: String -> Declaration declare str | null ds = NullD | otherwise = head ds where ds = [ d | (d,"") <- matchDeclaration str ] type TypeLib = [Declaration] typeLib :: TypeLib -- EXAMPLE: A system with 3 user-defined functions typeLib = map declare [ "double :: Int -> Int", "fst :: (Int, Int) -> Int", "snd :: (Int, Int) -> Int" ] {------------------------------------------------------------------------------ GETTING THE TYPE OF A GENERAL EXPRESSION ------------------------------------------------------------------------------} dec2expr :: Declaration -> Expr dec2expr NullD = NullE dec2expr (Declare e _) = e dec2type :: Declaration -> Type dec2type NullD = NullT dec2type (Declare _ t) = t getTypeFromLib :: FuncName -> Type getTypeFromLib f | null ts = NullT | otherwise = head ts where ts = [ dec2type d | d <- typeLib, dec2expr d == (FuncE f) ] -- Get the type of a specified expression getType :: Expr -> Type getType NullE = NullT getType (FuncE f) = getTypeFromLib f getType (IntE _) = UnaryT "Int" getType (FloatE _) = UnaryT "Float" getType (CharE _) = UnaryT "Char" getType (StringE _) = UnaryT "String" getType (BoolE _) = UnaryT "Bool" getType (ListE []) = NullT getType (ListE (e:es)) = ListT (getType e) getType (TupleE []) = NullT getType (TupleE [e]) = getType e getType (TupleE es) = TupleT (map getType es) getType (ApplyE []) = NullT getType (ApplyE [e]) = getType e getType (ApplyE (e:es)) = foldl doApplicationT (getType e) (map getType es) {------------------------------------------------------------------------------ SIMPLIFIED INPUT AND OUTPUT ------------------------------------------------------------------------------} -- Reads an expression and determines its type typeOf :: String -> Type typeOf = getType . asExpr -- Reads a valid type and outputs it asType :: String -> Type asType str | null ts = NullT | otherwise = head ts where ts = [ t | (t,"") <- matchType str ] -- Reads a valid expression and outputs it asExpr :: String -> Expr asExpr str | null es = NullE | otherwise = head es where es = [ e | (e,"") <- matchExpr str ] -- Parse an expression and give its type parse :: String -> Declaration parse str = Declare e t where e = asExpr str t = getType e -- _______________________________________________ Get your free email from http://mail.oxygen.ie Powered by Outblaze