git.iko.soy/elk
on fb59626 help sign in
elk/compiler/SourceSyntax/Type.hs
89 lines 2.7 kB history raw
1{-# OPTIONS_GHC -W #-}
2module SourceSyntax.Type where
4import Control.Applicative ((<$>), (<*>))
5import Data.Binary
6import qualified Data.Map as Map
7import SourceSyntax.PrettyPrint
8import qualified SourceSyntax.Helpers as Help
9import Text.PrettyPrint as P
11data Type = Lambda Type Type
12 | Var String
13 | Data String [Type]
14 | Record [(String,Type)] (Maybe String)
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 Nothing
24listOf :: Type -> Type
25listOf t = Data "_List" [t]
27tupleOf :: [Type] -> Type
28tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
30instance Pretty Type where
31 pretty tipe =
32 case tipe of
33 Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
34 where
35 t:ts = map prettyLambda (collectLambdas tipe)
36 prettyLambda t = case t of
37 Lambda _ _ -> P.parens (pretty t)
38 _ -> pretty t
40 Var x -> P.text x
41 Data "_List" [t] -> P.brackets (pretty t)
42 Data name tipes
43 | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
44 | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
45 Record fields ext ->
46 P.braces $ case ext of
47 Nothing -> prettyFields
48 Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields
49 where
50 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
51 prettyFields = commaSep . map prettyField $ fields
53collectLambdas :: Type -> [Type]
54collectLambdas tipe =
55 case tipe of
56 Lambda arg body -> arg : collectLambdas body
57 _ -> [tipe]
59prettyParens :: Type -> Doc
60prettyParens tipe = parensIf needed (pretty tipe)
61 where
62 needed =
63 case tipe of
64 Lambda _ _ -> True
65 Data "_List" [_] -> False
66 Data _ [] -> False
67 Data _ _ -> True
68 _ -> False
70instance Binary Type where
71 put tipe =
72 case tipe of
73 Lambda t1 t2 ->
74 putWord8 0 >> put t1 >> put t2
75 Var x ->
76 putWord8 1 >> put x
77 Data ctor tipes ->
78 putWord8 2 >> put ctor >> put tipes
79 Record fs ext ->
80 putWord8 3 >> put fs >> put ext
82 get = do
83 n <- getWord8
84 case n of
85 0 -> Lambda <$> get <*> get
86 1 -> Var <$> get
87 2 -> Data <$> get <*> get
88 3 -> Record <$> get <*> get
89 _ -> error "Error reading a valid type from serialized string"