git.iko.soy/elk
on 61b2cd6 help sign in
elk/compiler/SourceSyntax/Type.hs
96 lines 2.8 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2module SourceSyntax.Type where
4import Data.Binary
5import Data.Data
6import qualified Data.Map as Map
7import qualified SourceSyntax.Helpers as Help
8import Control.Applicative ((<$>), (<*>))
9import SourceSyntax.PrettyPrint
10import Text.PrettyPrint as P
12data Type = Lambda Type Type
13 | Var String
14 | Data String [Type]
15 | EmptyRecord
16 | Record [(String,Type)] Type
17 deriving (Eq, Show, Data, Typeable)
19fieldMap :: [(String,a)] -> Map.Map String [a]
20fieldMap fields =
21 foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
23recordOf :: [(String,Type)] -> Type
24recordOf fields = Record fields EmptyRecord
26listOf :: Type -> Type
27listOf t = Data "_List" [t]
29tupleOf :: [Type] -> Type
30tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
33instance Pretty Type where
34 pretty tipe =
35 case tipe of
36 Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
37 where t:ts = collectLambdas tipe
38 Var x -> P.text x
39 Data "_List" [t] -> P.brackets (pretty t)
40 Data name tipes
41 | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
42 | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
43 EmptyRecord -> P.braces P.empty
44 Record _ _ -> P.braces $ case ext of
45 EmptyRecord -> prettyFields
46 _ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields
47 where
48 (fields, ext) = collectRecords tipe
49 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
50 prettyFields = commaSep . map prettyField $ fields
52collectLambdas tipe =
53 case tipe of
54 Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body
55 Lambda arg body -> pretty arg : collectLambdas body
56 _ -> [pretty tipe]
58collectRecords = go []
59 where
60 go fields tipe =
61 case tipe of
62 Record fs ext -> go (fs ++ fields) ext
63 _ -> (fields, tipe)
65prettyParens tipe = parensIf needed (pretty tipe)
66 where
67 needed =
68 case tipe of
69 Lambda _ _ -> True
70 Data "_List" [_] -> False
71 Data _ [] -> False
72 Data _ _ -> True
73 _ -> False
75instance Binary Type where
76 put tipe =
77 case tipe of
78 Lambda t1 t2 ->
79 putWord8 0 >> put t1 >> put t2
80 Var x ->
81 putWord8 1 >> put x
82 Data ctor tipes ->
83 putWord8 2 >> put ctor >> put tipes
84 EmptyRecord ->
85 putWord8 3
86 Record fs ext ->
87 putWord8 4 >> put fs >> put ext
89 get = do
90 n <- getWord8
91 case n of
92 0 -> Lambda <$> get <*> get
93 1 -> Var <$> get
94 2 -> Data <$> get <*> get
95 3 -> return EmptyRecord
96 4 -> Record <$> get <*> get