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