AST.hs

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