AST.hs

   1 module AST where
   2
   3 import Util
   4 import Text.PrettyPrint
   5 import Data.List (groupBy)
   6
   7 import Control.Monad.State
   8
   9 data AST = AST [ Decl ]
  10
  11 instance Ppr AST where
  12     ppr (AST ds) =
  13         let dss = groupBy (\(Decl f _ _ _) (Decl g _ _ _) -> f == g) ds
  14         in vcat $ map pprDecls dss
  15         where
  16           pprDecls (d:ds) =
  17               ppr d $$ pprDeclsSimp ds
  18           pprDeclsSimp ds
  19               = vcat $ map (\(Decl f _ ps e) -> ppr (Decl f FTUndet ps e)) ds
  20
  21 instance Show AST where
  22     show = show . ppr
  23
  24 data Name
  25     = Name     String
  26     | IName    String [Int]
  27     | NCmpl    Name
  28     | NTuple   Name
  29     | NTupleV  Int      -- Variable Introduced by Tupling
  30     | NTupleVC Int      -- Variable Introduced by Tupling
  31     | NBwd     Name
  32     | NInv     Name
  33     | NCConF   Name     -- Constructor Name in Complement (1)
  34     | NCConE   Int      -- Constructor Name in Complement (2)
  35     | NCConU   Name Int -- After Renaming
  36           deriving (Eq,Ord)
  37
  38 instance Ppr Name where
  39     ppr  (Name s) = text s
  40     ppr  (IName s is) = text s <> text "_" <>
  41                         (hcat $ punctuate (text "_") $ map ppr is)
  42     ppr  (NCmpl n)  = ppr n <> text "_Cmpl"
  43     ppr  (NTuple n) = ppr n <> text "_T"
  44     ppr  (NTupleV i)  = text "tv" <> ppr i
  45     ppr  (NTupleVC i) = text "tc" <> ppr i
  46     ppr  (NInv n)     = ppr n <> text "_I"
  47     ppr  (NBwd n)     = ppr n <> text "_B"
  48     ppr  (NCConF n)   = text "C" <> ppr n
  49     ppr  (NCConE i)   = text "C" <> ppr i
  50     ppr  (NCConU n i) = text "C" <> ppr n <> text "_" <> ppr i
  51
  52 instance Show Name where
  53     show = show . ppr
  54
  55 data Decl = Decl Name FType [Pat] Exp
  56
  57 instance Ppr Decl where
  58     ppr (Decl fname ftype ps e) =
  59         addSig (ppr fname <>
  60                      parens (hsep $ punctuate comma (map ppr ps)) $$
  61                      nest 4 (text "=") $$
  62                      nest 6 (ppr e))
  63         where
  64           addSig d =
  65               case ftype of
  66                 FTUndet -> empty <> d
  67                 _       -> ppr fname <+> text "::" <+> ppr ftype $$ d
  68 instance Show Decl where
  69     show = show . ppr
  70
  71 data Exp  = EVar ID Type Name
  72           | EFun ID Type Name [Exp] -- Exp must be variable (treeless)
  73           | ECon ID Type Name [Exp]
  74        deriving (Ord,Eq)
  75
  76 type ID = Maybe Int
  77
  78 addPprType t d =
  79     case t of
  80       TUndet -> d
  81       _      -> d <> text "::" <> ppr t
  82
  83 instance Ppr Exp where
  84     ppr (EVar _ t vname)
  85         = addPprType t (ppr vname)
  86     ppr (EFun _ t fname es)
  87         = addPprType t $
  88             ppr fname <>
  89             parens (sep $ punctuate comma (map ppr es))
  90     ppr (ECon _ t cname [])
  91         = addPprType t $ ppr cname
  92     ppr (ECon _ t cname es)
  93         = addPprType t $
  94              ppr cname <>
  95              parens (sep $ punctuate comma (map ppr es))
  96
  97 instance Show Exp where
  98     show = show . ppr
  99
 100 data Pat  = PVar ID Type Name
 101           | PCon ID Type Name [Pat]
 102        deriving (Ord,Eq)
 103
 104 instance Ppr Pat where
 105     ppr (PVar _ t vname)
 106         = addPprType t (ppr vname)
 107     ppr (PCon _ t cname [])
 108         = addPprType t (ppr cname)
 109     ppr (PCon _ t cname ps)
 110         = addPprType t $ ppr cname
 111           <> parens (sep $ punctuate comma (map ppr ps))
 112
 113 instance Show Pat where
 114     show = show . ppr
 115
 116 data FType
 117     = TFun [Int] [Type] Type -- Quantified Vars, Input Types, Output Type.
 118       -- e.g. forall a. [a] -> a
 119       --      ==> TFun [TVar 1] [ TCon "[]" [TVar 1] ] (TVar 1)
 120     | FTUndet
 121       deriving (Eq,Ord)
 122
 123 instance Ppr FType where
 124     ppr (FTUndet) = text "??"
 125     ppr (TFun is ts t) =
 126         (case is of
 127           [] -> empty
 128           _  -> text "forall" <+>
 129                 hsep (map pprTV is) <>
 130                 text ".")
 131          <+> argType <+>
 132              ppr t
 133         where
 134           argType =
 135               case ts of
 136                 []  -> empty
 137                 [t] -> ppr t <+> text "->"
 138                 _   ->
 139                     parens (sep $ punctuate comma (map ppr ts))
 140                                <+> text "->"
 141           pprTV i = text ("t" ++ show i)
 142
 143 instance Show FType where
 144     show = show . ppr
 145
 146 data Type = TUndet           -- PlaceHolder
 147           | TVar Int         -- Type Variable
 148           | TCon Name [Type] -- e.g. [Int], Map Int [Char]
 149             deriving (Eq,Ord)
 150
 151 instance Ppr Type where
 152     ppr (TUndet)        = text "?"
 153     ppr (TVar i)        = text ("t" ++ show i)
 154     ppr (TCon tname ts) =
 155         ppr tname <+>
 156              hsep (map (\t -> f t (ppr t)) ts)
 157         where
 158           f (TUndet) x = x
 159           f (TVar i) x = x
 160           f (TCon tname []) x = x
 161           f _ x = parens x
 162 instance Show Type where
 163     show = show . ppr
 164
 165
 166
 167 typeofP (PVar _ t _)   = t
 168 typeofP (PCon _ t _ _) = t
 169 typeofE (EVar _ t _)   = t
 170 typeofE (ECon _ t _ _) = t
 171 typeofE (EFun _ t _ _) = t
 172
 173
 174 idofP (PVar t _ _)   = t
 175 idofP (PCon t _ _ _) = t
 176 idofE (EVar t _ _)   = t
 177 idofE (ECon t _ _ _) = t
 178 idofE (EFun t _ _ _) = t
 179
 180 varsP p = snub $ vp p
 181     where vp (PVar _ _ x)    = [x]
 182           vp (PCon _ _ _ ps) = concatMap vp ps
 183 varsE e = snub $ ve e
 184     where ve (EVar _ _ x)    = [x]
 185           ve (ECon _ _ _ es) = concatMap ve es
 186           ve (EFun _ _ _ es) = concatMap ve es
 187
 188
 189 -- assignIDsAST :: AST -> AST
 190 assignIDsAST (AST decls) =
 191     AST $ evalState (mapM assignIDsD decls) 10
 192
 193 assignIDsD :: Decl -> State Int (Decl)
 194 assignIDsD (Decl f t ps e) =
 195     do { ps' <- mapM assignIDsP ps
 196        ; e   <- assignIDsE e
 197        ; return $ Decl f t ps e }
 198     where
 199       uniq = do { i <- get; put (i+1) ; return $ Just (i+1) }
 200       assignIDsE (EVar _ t x) =
 201           do { i <- uniq
 202              ; return $ EVar i t x }
 203       assignIDsE (ECon _ t c es) =
 204           do { i <- uniq
 205              ; es' <- mapM assignIDsE es
 206              ; return $ ECon i t c es' }
 207       assignIDsE (EFun _ t f es) =
 208           do { i <- uniq
 209              ; es' <- mapM assignIDsE es
 210              ; return $ EFun i t f es' }
 211
 212       assignIDsP (PVar _ t x) =
 213           do { i <- uniq
 214              ; return $ PVar i t x }
 215       assignIDsP (PCon _ t c ps) =
 216           do { i <- uniq
 217              ; ps' <- mapM assignIDsP ps
 218              ; return $ PCon i t c ps' }
 219
 220 isSameFunc (Decl f _ _ _) (Decl g _ _ _) = f == g
 221
 222
 223 -- After Tupling
 224
 225 data TAST  = TAST [TDecl]
 226 data TDecl = TDecl Name [Pat] [Exp] [VDecl] -- f(ps) = es where ...
 227 data VDecl = VDecl [Name] Name [Name]          -- vs = f(us)
 228
 229 instance Ppr TAST where
 230     ppr (TAST tdecls) = vcat $ map ppr tdecls
 231 instance Ppr TDecl where
 232     ppr (TDecl f ps es vdecls) =
 233         ppr f <> parens (hsep $ punctuate comma (map ppr ps)) $$
 234             nest 4 (text "=" <+> parens (hsep $ punctuate comma (map ppr es))) $$
 235             if null vdecls then
 236                 empty
 237             else
 238                 (nest 6 (text "where") $$
 239                  nest 8 (vcat $ map ppr vdecls))
 240 instance Ppr VDecl where
 241     ppr (VDecl vs f us) = parens (hsep $ punctuate comma (map ppr vs))
 242                           <+> text "=" <+> ppr f <>
 243                           parens (hsep $ punctuate comma (map ppr us))