[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