module WASH.CGI.Types where
import Maybe
data TySpec =
TS TyRep [TyDecl]
deriving (Read, Show, Eq)
data TyRep =
TRBase String
| TRVar String
| TRTuple [TyRep]
| TRData String [TyRep]
deriving (Read, Show, Eq)
data TyDecl =
TD String [String] [ConRep]
deriving (Read, Show, Eq)
data ConRep =
CR String
(Maybe [String])
[TyRep]
deriving (Read, Show, Eq)
class Types a where
ty :: a -> TySpec
instance Types () where
ty i = TS (TRBase "()") []
instance Types Bool where
ty i = TS (TRBase "Bool") []
instance Types Int where
ty i = TS (TRBase "Int") []
instance Types Integer where
ty i = TS (TRBase "Integer") []
instance Types Double where
ty d = TS (TRBase "Double") []
instance Types Float where
ty d = TS (TRBase "Float") []
instance Types Char where
ty c = TS (TRBase "Char") []
instance (Types a, Types b) => Types (a,b) where
ty xy = TS (TRTuple [tra, trb]) (merge defsa defsb)
where TS tra defsa = ty (fst xy)
TS trb defsb = ty (snd xy)
instance (Types a, Types b, Types c) => Types (a,b,c) where
ty ~(xa,xb,xc) = TS (TRTuple [tra, trb, trc]) (merge (merge defsa defsb) defsc)
where TS tra defsa = ty xa
TS trb defsb = ty xb
TS trc defsc = ty xc
instance (Types a, Types b, Types c, Types d) => Types (a,b,c,d) where
ty ~(xa,xb,xc,xd) = TS (TRTuple [tra, trb, trc, trd])
(merge (merge defsa defsb) (merge defsc defsd))
where TS tra defsa = ty xa
TS trb defsb = ty xb
TS trc defsc = ty xc
TS trd defsd = ty xd
instance (Types a, Types b, Types c, Types d, Types e) => Types (a,b,c,d,e) where
ty ~(xa,xb,xc,xd,xe) = TS (TRTuple [tra, trb, trc, trd, tre])
(merges [defsa, defsb, defsc, defsd, defse])
where TS tra defsa = ty xa
TS trb defsb = ty xb
TS trc defsc = ty xc
TS trd defsd = ty xd
TS tre defse = ty xe
instance (Types a) => Types [a] where
ty xs = TS (TRData (tdName listDef) [tr]) (merge defs [listDef])
where TS tr defs = ty (head xs)
listDef :: TyDecl
listDef = TD "[]" ["a"] [CR "[]" Nothing []
,CR ":" Nothing [TRVar "a"
,TRData (tdName listDef) [TRVar "a"]]]
instance (Types a) => Types (Maybe a) where
ty mx = TS (TRData (tdName maybeDef) [tr]) (merge defs [maybeDef])
where TS tr defs = ty (fromJust mx)
maybeDef :: TyDecl
maybeDef =
TD "Maybe" ["a"][CR "Nothing" Nothing []
,CR "Just" Nothing [TRVar "a"]]
instance (Types a, Types b) => Types (Either a b) where
ty xy = TS (TRData (tdName eitherDef) [tra, trb])
(merge (merge defsa defsb) [eitherDef])
where TS tra defsa = ty (fromLeft xy)
TS trb defsb = ty (fromRight xy)
fromLeft (Left x) = x
fromRight (Right y) = y
eitherDef :: TyDecl
eitherDef =
TD "Either"
["a", "b"]
[CR "Left" Nothing [TRVar "a"]
,CR "Right" Nothing [TRVar "b"]]
tdName (TD name _ _) = name
merge :: [TyDecl] -> [TyDecl] -> [TyDecl]
merge [] ys = ys
merge xs [] = xs
merge (x:xs) (y:ys)
| x == y = x : merge xs ys
| tdName x == tdName y = error ("Different types with identical name: " ++ tdName x)
| tdName x <= tdName y = x : merge xs (y:ys)
| otherwise = y : merge (x:xs) ys
merges :: [[TyDecl]] -> [TyDecl]
merges tss = foldr merge [] tss
class TID a where
tid :: a -> ShowS
instance TID TySpec where
tid (TS tyRep tyDecls) =
tid tyRep . tid tyDecls
instance TID a => TID [a] where
tid [] = showChar '.'
tid (x : xs) = showChar ',' . tid x . tid xs
instance TID TyRep where
tid (TRBase str) = showChar 'B' . shows str
tid (TRVar str) = showChar 'V' . shows str
tid (TRTuple tyReps) = showChar 'T' . tid tyReps
tid (TRData str tyReps) = showChar 'D' . shows str . tid tyReps
instance TID TyDecl where
tid (TD name tyvars conreps) =
shows name . shows tyvars . tid conreps
instance TID ConRep where
tid (CR ctorname mFields tyReps) =
shows ctorname . shows mFields . tid tyReps