Haskell type aliases

aliases.hs

import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Function (on)
import Data.List


data SimpleType = SimpleType TyCon [TyVar]

data Type = Type TyCon [Type]
          | TyVar TyVar

type TyCon = String
type TyVar = String

type Aliases = Map.Map TyCon ([TyVar], Type)

resolveTopAlias :: Aliases -> Type -> Type
resolveTopAlias aliases origType@(Type constr params) = fromMaybe origType $ do
  (vars, ty) <- Map.lookup constr aliases
  let environment = Map.fromList $ zip vars params
  return $ nextAlias (mapType environment ty) (drop (length vars) params)
  where mapType env (Type con ps) = Type con (map (mapType env) ps)
        mapType env var@(TyVar v) = Map.findWithDefault var v env
        nextAlias (Type con ps) extraParams = resolve con (ps ++ extraParams)
        resolve con ps = resolveTopAlias aliases (Type con ps)

typeEq :: Aliases -> Type -> Type -> Bool
typeEq aliases = eqForAliasFree `on` resolveTopAlias aliases
  where eqForAliasFree (Type con1 ps1) (Type con2 ps2) =
          con1 == con2 && (and $ zipWith (typeEq aliases) ps1 ps2)


instance Show SimpleType where
  show (SimpleType constr vars) = intercalate " " (constr : vars)

instance Show Type where
  show = helper True
         where helper isTop (Type constr params) =
                 let (leftPar, rightPar) = if not isTop && length params > 0
                                           then ("(", ")") else ("", "")
                 in  leftPar ++ intercalate " " (constr : map (helper False) params) ++ rightPar
               helper _ (TyVar v) = v

aliasesShow :: Aliases -> String
aliasesShow = intercalate "\n" .
              map (\(con, (vars, ty)) -> "type " ++ show (SimpleType con vars) ++ " = " ++ show ty) .
              Map.toList

main :: IO ()
main = do
  let nullary constr = Type constr []
  let (int, char) = (nullary "Int", nullary "Char")
  let typeForTest leaf1 leaf2 = Type "Either2" [Type "Maybe" [nullary leaf1], nullary leaf2]
  let test ok = putStrLn $ if ok then "[ OK ]" else "[FAIL]"
  test $ typeEq Map.empty (typeForTest "Int" "Char") (typeForTest "Int" "Char")
  test $ not $ typeEq Map.empty (typeForTest "Int" "Double") (typeForTest "Int" "Char")
  test $ not $ typeEq Map.empty (typeForTest "Int" "Double") (typeForTest "Char" "Double")
  let aliases = Map.fromList [
                  ("MyInt", ([], nullary "Int")),
                  ("MyChar", ([], nullary "Char")),
                  ("MyInt2", ([], nullary "MyInt")),
                  ("MyInt3", ([], nullary "MyInt2")),
                  ("MyDouble", ([], nullary "Double")),
                  ("Either2", (["a", "b"], Type "Either" [TyVar "a", TyVar "b"])),
                  ("EitherCurried", (["fst"], Type "Either2" [Type "Maybe" [TyVar "fst"]])),
                  ("EitherCurried2", (["fst"], Type "EitherCurried" [TyVar "fst"])),
                  ("Test", (["leaf1", "leaf2"], Type "EitherCurried2" [TyVar "leaf1", TyVar "leaf2"]))
                ]
  test $ typeEq aliases (typeForTest "MyInt" "Char") (typeForTest "Int" "MyChar")
  test $ not $ typeEq Map.empty (typeForTest "MyInt" "Double") (typeForTest "MyInt" "MyChar")
  test $ typeEq aliases (Type "Test" [int, char]) (Type "Test" [int, char])
  test $ typeEq aliases (Type "Test" [int, nullary "MyChar"]) (Type "Test" [nullary "MyInt", char])
  let aliased1 = Type "Test" [int, nullary "MyDouble"]
  let aliased2 = typeForTest "MyInt3" "Double"
  test $ typeEq aliases aliased1 aliased2
  test $ not $ typeEq aliases (Type "Test" [int, nullary "Double"]) (typeForTest "MyInt" "MyChar")
  putStrLn $ aliasesShow aliases
  putStrLn $ show aliased1 ++ "  ~~top~~>  " ++ show (resolveTopAlias aliases aliased1)
  putStrLn $ show aliased2 ++ "  ~~top~~>  " ++ show (resolveTopAlias aliases aliased1)

topdecl -> type simpletype = type | ..
simpletype -> tycon tyvar1 .. tyvarN (N >= 0)
type -> btype [-> type]
btype -> [btype] atype
atype -> gtycon | tyvar | '('type1 ','.. typeN')' | '['type']' | '('type')' (N >= 2)
gtycon -> qtycon | '(' ')' | ..
qtycon -> [modid '.'] tycon
tycon -> conid
.....

(http://www.haskell.org/onlinereport/syntax-iso.html)

[ OK ]
[ OK ]
[ OK ]
[ OK ]
[ OK ]
[ OK ]
[ OK ]
[ OK ]
[ OK ]
type Either2 a b = Either a b
-- type alias currying isn't supported by Haskell actually, replace Either2 below with Either
type EitherCurried fst = Either2 (Maybe fst)
type EitherCurried2 fst = EitherCurried fst
type MyChar = Char
type MyDouble = Double
type MyInt = Int
type MyInt2 = MyInt
type MyInt3 = MyInt2
type Test leaf1 leaf2 = EitherCurried2 leaf1 leaf2
Test Int MyDouble ~~top~~> Either (Maybe Int) MyDouble
Either2 (Maybe MyInt3) Double ~~top~~> Either (Maybe Int) MyDouble