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