[Haskell-cafe] Haskell Questions
Mike Richards
mike.richards at oxygen.ie
Thu Apr 21 06:37:29 EDT 2005
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
More information about the Haskell-Cafe
mailing list