core (empty) → 0.1
raw patch · 7 files changed
+774/−0 lines, 7 filesdep +basedep +bytestringdep +parsecsetup-changed
Dependencies added: base, bytestring, parsec, pretty
Files
- LICENSE +35/−0
- Setup.lhs +3/−0
- core.cabal +17/−0
- src/Language/Core.hs +9/−0
- src/Language/Core/Parser.hs +415/−0
- src/Language/Core/Pretty.hs +181/−0
- src/Language/Core/Syntax.lhs +114/−0
+ LICENSE view
@@ -0,0 +1,35 @@+Copyright (c) 2009, David Himmelstrup+All rights reserved.++Redistribution and use in source and binary forms,+with or without modification, are permitted provided+that the following conditions are met:++ * Redistributions of source code must retain+ the above copyright notice, this list of+ conditions and the following disclaimer.+ * Redistributions in binary form must reproduce+ the above copyright notice, this list of+ conditions and the following disclaimer in the+ documentation and/or other materials provided+ with the distribution.+ * Neither the name of David Himmelstrup nor the+ names of other contributors may be used to+ endorse or promote products derived from this+ software without specific prior written permission.+++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY+OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ core.cabal view
@@ -0,0 +1,17 @@+name: core+version: 0.1+synopsis: External core parser and pretty printer.+description: External core parser and pretty printer.+category: Language+license: BSD3+license-file: LICENSE+author: David Himmelstrup+maintainer: lemmih@gmail.com+build-Depends: base, parsec, bytestring, pretty+ghc-options: +build-type: Simple+hs-source-dirs: src+exposed-modules: Language.Core+ Language.Core.Syntax+ Language.Core.Parser+ Language.Core.Pretty
+ src/Language/Core.hs view
@@ -0,0 +1,9 @@+module Language.Core+ ( module Language.Core.Parser+ , module Language.Core.Syntax+ , module Language.Core.Pretty+ ) where++import Language.Core.Parser+import Language.Core.Syntax+import Language.Core.Pretty
+ src/Language/Core/Parser.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE NoMonomorphismRestriction, PatternGuards #-}+module Language.Core.Parser+ ( parseModule+ ) where++import Data.Char+import Data.Ratio+import Text.ParserCombinators.Parsec+import Control.Monad+import Debug.Trace++import Language.Core.Syntax+import Language.Core.Pretty++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L++type LParser = GenParser (Pos Token) ()++data Pos a = Pos !Int !Int a deriving Show++getToken (Pos _ _ token) = token+mkPos line col token = Pos (fromIntegral line) (fromIntegral col) token++data Token+ = Keyword String+ | Colon+ | DColon+ | SColon+ | Arrow+ | LParen+ | RParen+ | LBrace+ | RBrace+ | Dot+ | Equal+ | At+ | Star+ | Hash+ | Dash+ | Percent+ | QuestionMark+ | Backslash+ | Uname L.ByteString+ | Lname L.ByteString+ | String String+ | Char Char+ | Number Integer+ deriving (Show, Eq)++lexer :: L.ByteString -> [Pos Token]+lexer = worker 1 0+ where worker line col inp+ = case L.uncons inp of+ Nothing -> []+ Just ('\n',cs) -> worker (line+1) 0 cs+ Just ('"',cs) -> let (str,len,rest) = lex_string cs+ in mkPos line col (String str) : worker line (col+len+2) rest+ Just ('\'',cs) -> let (char, len, rest) = lex_char cs+ in mkPos line col (Char char) : worker line (col+len+2) (L.drop 1 rest)+ Just (c,cs)+ | isSpace c -> worker line (col+1) cs+ | Just (token,len,rest) <- findSymbol inp+ -> mkPos line col token : worker line (col+len) rest+ | isLetter c -> let (name, rest) = L.span isNameChar inp+ token = if isUpper c then Uname name+ else Lname name+ in mkPos line col token : worker line (col+L.length name) rest+ | isDigit c -> let (digits, rest) = L.span isDigit inp+ token = Number (read (L.unpack digits))+ in mkPos line col token : worker line (col+L.length digits) rest+ | otherwise -> worker line (col+1) cs -- error $ "Unhandled: " ++ take 20 (L.unpack inp)++lex_string = worker 0 ""+ where worker len acc inp+ = case L.uncons inp of+ Nothing -> error "lexer failure in string: eof"+ Just ('"',cs) -> (reverse acc, len, cs)+ _ -> let (c, l, cs) = lex_char inp+ in worker (len+l) (c:acc) cs++lex_char inp = case L.uncons inp of+ Just ('\\',cs) -> case L.unpack (L.take 3 cs) of+ ['x',ah,al] | all isHexDigit [ah,al]+ -> (chr (digitToInt ah*16 + digitToInt al), 4, L.drop 3 cs)+ _ -> error "lexer failure in string: bad hex"+ Just (c,cs) | c >= '\x20' && c <= '\x7E' && c `notElem` ['\x22', '\x27', '\x5C']+ -> (c, 1, cs)+ Just (c,cs) -> error $ "lexer failure in string: invalid char: " ++ show c+++isNameChar c = isUpper c || isLower c || isDigit c || c == '\''+++findSymbol inp = worker symbols+ where worker [] = Nothing+ worker ((str,token):xs) = if str `L.isPrefixOf` inp+ then Just (token, L.length str, L.drop (L.length str) inp)+ else worker xs++symbols = [ (L.pack "::", DColon)+ , (L.pack ":", Colon)+ , (L.pack ";", SColon)+ , (L.pack "(", LParen)+ , (L.pack ")", RParen)+ , (L.pack "{", LBrace)+ , (L.pack "}", RBrace)+ , (L.pack "->", Arrow)+ , (L.pack ".", Dot)+ , (L.pack "=", Equal)+ , (L.pack "@", At)+ , (L.pack "*", Star)+ , (L.pack "?", QuestionMark)+ , (L.pack "#", Hash)+ , (L.pack "-", Dash)+ , (L.pack "\\", Backslash)+ , (L.pack "%module", Keyword "module")+ , (L.pack "%data", Keyword "data")+ , (L.pack "%newtype", Keyword "newtype")+ , (L.pack "%rec", Keyword "rec")+ , (L.pack "%case", Keyword "case")+ , (L.pack "%forall", Keyword "forall")+ , (L.pack "%let", Keyword "let")+ , (L.pack "%note", Keyword "note")+ , (L.pack "%external", Keyword "external")+ , (L.pack "%dynexternal", Keyword "dynexternal")+ , (L.pack "%label", Keyword "label")+ , (L.pack "%_", Keyword "_")+ , (L.pack "%cast", Keyword "cast")+ , (L.pack "%left", Keyword "left")+ , (L.pack "%right", Keyword "right")+ , (L.pack "%sym", Keyword "sym")+ , (L.pack "%unsafe", Keyword "unsafe")+ , (L.pack "%inst", Keyword "inst")+ , (L.pack "%trans", Keyword "trans")+ , (L.pack "%unsafe", Keyword "unsafe")+ , (L.pack "%of", Keyword "of")+ , (L.pack "%in", Keyword "in")+ , (L.pack "%", Percent)+ ]++main :: IO ()+main = do inp <- L.readFile --"./hcr/Tuple.hcr"+ --"./src/ExternalCore.hcr"+ "../base.hcr"+ --print (length (lexer inp))+ --mapM_ print (lexer inp)+ parseTest (many1 moduleP >>= \m -> notFollowedBy anyToken >> return (map ppModule m) >> return ()) (lexer inp)+++parseModule :: SourceName -> L.ByteString -> Either ParseError Module+parseModule src inp = runParser moduleP () src (lexer inp)++moduleP :: LParser Module+moduleP = do keyword "module"+ pkg <- pkgname+ matchToken Colon+ modName <- mident+ trace (L.unpack modName) $ return ()+ tdefs <- tdef `endBy` (matchToken SColon)+ vdefgs <- vdefg `endBy` (matchToken SColon)+ return $ Module (pkg,modName) tdefs vdefgs+++vdefg = choice+ [ do keyword "rec"+ braces $ liftM Rec (vdef `sepBy1` (matchToken SColon))+ , do v <- vdef+ return $ Nonrec v+ ] <?> "vdefg"++vdef = do name <- try qvar <|> do name <- lname; return (L.empty,L.empty,name)+ matchToken DColon+ t <- ty+ matchToken Equal+ e <- expP+ return (False, name, t, e)+ <?> "vdef"++expP = choice+ [ do fn <- aexp+ args <- many arg+ let app e (Left t) = Appt e t+ app e (Right a) = App e a+ return $ foldl app fn args+ , do matchToken Backslash+ binds <- many1 binder+ matchToken Arrow+ e <- expP+ return $ foldr Lam e binds+ , do keyword "case"+ t <- aty+ e <- expP+ keyword "of"+ b <- vbind+ alts <- braces $ alt `sepBy1` (matchToken SColon)+ return $ Case e b t alts+ , do keyword "cast"+ e <- aexp+ t <- aty+ return $ Cast e t+ , do keyword "let"+ def <- vdefg+ keyword "in"+ e <- expP+ return $ Let def e+ , do keyword "note"+ note <- stringP+ e <- expP+ return $ Note note e+ , do keyword "external"+ conv <- lname+ target <- stringP+ t <- aty+ return $ External target (L.unpack conv) t+ , do keyword "dynexternal"+ conv <- lname+ t <- aty+ return $ DynExternal (L.unpack conv) t+ , do keyword "label"+ str <- stringP+ return $ Label str+ ]++alt = choice [ do con <- qdcon+ tbinds <- many (matchToken At >> tbind)+ vbinds <- many vbind+ matchToken Arrow+ e <- expP+ return $ Acon con tbinds vbinds e+ , do keyword "_"+ matchToken Arrow+ e <- expP+ return $ Adefault e+ , do l <- lit+ matchToken Arrow+ e <- expP+ return $ Alit l e+ ] <?> "alt"++binder = choice+ [ do matchToken At+ liftM Tb tbind+ , liftM Vb vbind+ ] <?> "binder"++arg = choice+ [ do matchToken At+ liftM Left aty+ , liftM Right aexp+ ] <?> "arg"++aexp = choice+ [ try $ liftM Dcon qdcon+ , try $ liftM Var qvar+ , try $ liftM Var (lname >>= \name -> return (L.empty,L.empty,name))+ , try $ liftM Lit lit+ , parens expP+ ]++lit = choice+ [ try $ parens $+ do cs <- stringP+ matchToken DColon+ t <- ty+ return (Lstring cs t)+ , try $ parens $+ do c <- charP+ matchToken DColon+ t <- ty+ return (Lchar c t)+ , try $ parens $+ do m <- optional (matchToken Dash)+ ds <- number+ matchToken DColon+ t <- ty+ return (Lint ds t)+ , try $ parens $+ do n <- number <|> parens (matchToken Dash >> number)+ matchToken Percent+ d <- number+ matchToken DColon+ t <- ty+ return $ Lrational (n % d) t+ ]++++tdef = choice [dataP, newtypeP]++dataP = do keyword "data"+ name <- qtycon+ tbinds <- many tbind+ matchToken Equal+ cdefs <- braces $ cdef `sepBy` matchToken SColon+ return $ Data name tbinds cdefs+ <?> "dataP"++newtypeP = do keyword "newtype"+ name <- qtycon+ coercion <- qtycon+ tbinds <- many tbind+ matchToken Equal+ t <- ty+ return $ Newtype name coercion tbinds t++cdef = do name <- qdcon+ tbinds <- many (matchToken At >> tbind)+ tys <- many aty+ return $ Constr name tbinds tys++aty = choice+ [ try $ liftM Tcon qtycon+ , liftM Tvar tyvar+ , parens ty+ , do keyword "trans"+ liftM2 TransCoercion aty aty+ , do keyword "sym"+ liftM SymCoercion aty+ , do keyword "right"+ liftM RightCoercion aty+ , do keyword "left"+ liftM LeftCoercion aty+ , do keyword "unsafe"+ liftM2 UnsafeCoercion aty aty+ , do keyword "inst"+ liftM2 InstCoercion aty aty+ ]++bty = do ts <- many1 aty+ return $ foldl1 Tapp ts++ty = choice+ [ do keyword "forall"+ binds <- many1 tbind+ matchToken Dot+ t <- ty+ return $ foldr Tforall t binds+ , try $ do a <- bty+ matchToken Arrow+ b <- ty+ return (Tapp (Tapp (Tcon tcArrow) a) b)+ , bty+ ]+++tbind = choice+ [ do var <-tyvar+ return $ (var, Klifted)+ , parens $+ do var <- tyvar+ matchToken DColon+ k <- kind+ return (var, k)+ ]++vbind = parens $ do v <- lname+ matchToken DColon+ t <- ty+ return (v,t)+++akind = choice [ matchToken Star >> return Klifted+ , matchToken Hash >> return Kunlifted+ , matchToken QuestionMark >> return Kopen+ , parens $ kind ]++kind = choice [ try $ do atomic <- akind+ matchToken Arrow+ k <- kind+ return (Karrow atomic k)+ , akind ]++tyvar = lname++qdcon = qual uname+qtycon = qual uname+qvar = qual lname++qual a = do pkg <- pkgname+ matchToken Colon+ mod <- uname+ matchToken Dot+ t <- a+ return (pkg, mod, t)++tycon = uname++pkgname = uname <|> lname++mident = uname++--namechar = lower <|> upper <|> digit <|> char '\''+++movePos p (Pos l c _) _ = setSourceLine (setSourceColumn p c) l+uname = tokenPrim (const "uname") movePos (\t -> case getToken t of Uname n -> Just n; _ -> Nothing)+lname = tokenPrim (const "lname") movePos (\t -> case getToken t of Lname n -> Just n; _ -> Nothing)+number = tokenPrim (const "number") movePos (\t -> case getToken t of Number n -> Just n; _ -> Nothing)+stringP = tokenPrim (const "string") movePos (\t -> case getToken t of String n -> Just n; _ -> Nothing)+charP = tokenPrim (const "char") movePos (\t -> case getToken t of Char n -> Just n; _ -> Nothing)++matchToken token+ = tokenPrim (const $ show token) movePos (\t -> if getToken t == token then Just () else Nothing)+++-- Utilities+parens = between (matchToken LParen)+ (matchToken RParen)++braces = between (matchToken LBrace)+ (matchToken RBrace)++keyword txt = matchToken (Keyword txt)+
+ src/Language/Core/Pretty.hs view
@@ -0,0 +1,181 @@+module Language.Core.Pretty+ ( ppModule+ ) where++import Language.Core.Syntax++import Text.PrettyPrint+import Data.Char+import qualified Data.ByteString.Lazy.Char8 as L++ppModule :: Module -> Doc+ppModule (Module (pkg,mod) tdefs vdefgs)+ = keyword "module" <+> text (L.unpack pkg) <> colon <> text (L.unpack mod) $+$+ indent body+ where body = types $$ definitions+ types = endWith (char ';') $ map ppTdef tdefs+ definitions = endWith (char ';') $ map ppVdefg vdefgs++ppVdefg (Rec defs)+ = keyword "rec" $$ braces (indent (vcat (punctuate (char ';') (map ppVdef defs))))+ppVdefg (Nonrec def)+ = ppVdef def++ppVdef (_local, name, ty, expr)+ = ppQual name <+> text "::" <+> ppTy ty <+> equals $$ indent (ppExp expr)++ppAexp, pfexp, ppExp :: Exp -> Doc+ppAexp (Var x) = ppQual x+ppAexp (Dcon x) = ppQual x+ppAexp (Lit l) = plit l+ppAexp e = parens(ppExp e)++plamexp :: [Bind] -> Exp -> Doc+plamexp bs (Lam b e) = plamexp (bs ++ [b]) e+plamexp bs e = sep [sep (map pbind bs) <+> text "->",+ indent (ppExp e)]++pbind :: Bind -> Doc+pbind (Tb tb) = char '@' <+> ppTbind tb+pbind (Vb vb) = pvbind vb++pfexp (App e1 e2) = pappexp e1 [Left e2]+pfexp (Appt e t) = pappexp e [Right t]+pfexp e = ppAexp e++pappexp :: Exp -> [Either Exp Ty] -> Doc+pappexp (App e1 e2) as = pappexp e1 (Left e2:as)+pappexp (Appt e t) as = pappexp e (Right t:as)+pappexp e as = fsep (ppAexp e : map pa as)+ where pa (Left e) = ppAexp e+ pa (Right t) = char '@' <+> ppAty t++ppExp (Lam b e) = char '\\' <+> plamexp [b] e+ppExp (Let vd e) = (text "%let" <+> ppVdefg vd) $$ (text "%in" <+> ppExp e)+ppExp (Case e vb ty alts) = sep [text "%case" <+> ppAty ty <+> ppAexp e,+ text "%of" <+> pvbind vb]+ $$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))+ppExp (Cast e co) = (text "%cast" <+> parens (ppExp e)) $$ ppAty co+ppExp (Note s e) = (text "%note" <+> pstring s) $$ ppExp e+ppExp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ ppAty t+ppExp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ ppAty t+ppExp (Label n) = (text "%label" <+> pstring n)+ppExp e = pfexp e++pvbind :: Vbind -> Doc+pvbind (x,t) = parens(text (L.unpack x) <> text "::" <> ppTy t)++palt :: Alt -> Doc+palt (Acon c tbs vbs e) =+ sep [ppQual c, + sep (map pattbind tbs),+ sep (map pvbind vbs) <+> text "->"]+ $$ indent (ppExp e)+palt (Alit l e) = + (plit l <+> text "->")+ $$ indent (ppExp e)+palt (Adefault e) = + (text "%_ ->")+ $$ indent (ppExp e)++plit :: Lit -> Doc+plit (Lint i t) = parens (integer i <> text "::" <> ppTy t)+-- we use (text (show r)) because "(rational r)" was printing out things+-- like "2.0e-2" (which isn't External Core)+plit (Lrational r t) = parens (text (show r) <> text "::" <> ppTy t)+plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> ppTy t)+plit (Lstring s t) = parens (pstring s <> text "::" <> ppTy t)++pstring :: String -> Doc+pstring s = doubleQuotes(text (escape s))++escape :: String -> String+escape s = foldr f [] (map ord s)+ where + f cv rest+ | cv > 0xFF = '\\':'x':hs ++ rest+ | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = + '\\':'x':h1:h0:rest+ where (q1,r1) = quotRem cv 16+ h1 = intToDigit q1+ h0 = intToDigit r1+ hs = dropWhile (=='0') $ reverse $ mkHex cv+ mkHex 0 = ""+ mkHex cv = intToDigit r : mkHex q+ where (q,r) = quotRem cv 16+ f cv rest = (chr cv):rest++++ppTdef (Data qual tbinds cdefs)+ = (keyword "data" <+> ppQual qual <+> hsep (map ppTbind tbinds) <+> equals) $$+ indent (braces (vcat $ punctuate (char ';') $ map ppCdef cdefs))+ppTdef (Newtype name coercion tbinds ty)+ = (keyword "newtype" <+> ppQual name <+> ppQual coercion <+> hsep (map ppTbind tbinds)) $$+ indent (equals <+> ppTy ty)++ppCdef (Constr qual tbinds ty)+ = ppQual qual <+> sep (map (char '@' <+>) (map ppTbind tbinds)) <+> sep (map ppAty ty)++ppTbind (var, Klifted) = text (L.unpack var)+ppTbind (var, kind) = parens $ text (L.unpack var) <+> text "::" <+> ppKind kind++pattbind (t,k) = char '@' <> ppTbind (t,k)++ppKind' Klifted = char '*'+ppKind' Kunlifted = char '#'+ppKind' Kopen = char '?'+ppKind' k = parens (ppKind k)++ppKind (Karrow k1 k2) = parens (ppKind' k1 <> text "->" <> ppKind k2)+--pkind (Keq t1 t2) = parens (parens (pty t1) <+> text ":=:" <+> +-- parens (pty t2))+ppKind k = ppKind' k++ppAty, ppBty, ppTy :: Ty -> Doc+ppAty (Tvar n) = text (L.unpack n)+ppAty (Tcon c) = ppQual c+ppAty t = parens (ppTy t)++ppBty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [ppBty t1, text "->",ppTy t2])+ppBty (Tapp t1 t2) = parens $ ppAppty t1 [t2] +ppBty t = ppAty t++ppTy (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [ppBty t1, text "->",ppTy t2]+ppTy (Tforall tb t) = text "%forall" <+> ppForall [tb] t+ppTy (TransCoercion t1 t2) =+ sep [text "%trans", ppAty t1, ppAty t2]+ppTy (SymCoercion t) =+ sep [text "%sym", ppAty t]+ppTy (UnsafeCoercion t1 t2) =+ sep [text "%unsafe", ppAty t1, ppAty t2]+ppTy (LeftCoercion t) =+ sep [text "%left", ppAty t]+ppTy (RightCoercion t) =+ sep [text "%right", ppAty t]+ppTy (InstCoercion t1 t2) =+ sep [text "%inst", ppAty t1, ppAty t2]+ppTy t = ppBty t++ppAppty :: Ty -> [Ty] -> Doc+ppAppty (Tapp t1 t2) ts = ppAppty t1 (t2:ts)+ppAppty t ts = sep (map ppAty (t:ts))++ppForall :: [Tbind] -> Ty -> Doc+ppForall tbs (Tforall tb t) = ppForall (tbs ++ [tb]) t+ppForall tbs t = hsep (map ppTbind tbs) <+> char '.' <+> ppTy t++++ppQual (pkg,mod,ident)+ | L.null pkg && L.null mod = text (L.unpack ident)+ | otherwise = text (L.unpack pkg) <> colon <> text (L.unpack mod) <> char '.' <> text (L.unpack ident)+++-- Helpers++endWith end docs = vcat (map (<> end) docs)++keyword str = char '%' <> text str++indent = nest 2
+ src/Language/Core/Syntax.lhs view
@@ -0,0 +1,114 @@+%+% (c) The University of Glasgow 2001-2006+%+\begin{code}+module Language.Core.Syntax where++import qualified Data.ByteString.Lazy.Char8 as L++data Module+ = Module (Pkgname, Mname) [Tdef] [Vdefg]+ deriving (Show)++data Tdef + = Data (Qual Tcon) [Tbind] [Cdef]+ | Newtype (Qual Tcon) (Qual Tcon) [Tbind] Ty+ deriving (Show)++data Cdef + = Constr (Qual Dcon) [Tbind] [Ty]+ | GadtConstr (Qual Dcon) Ty+ deriving (Show)++data Vdefg + = Rec [Vdef]+ | Nonrec Vdef+ deriving (Show)++-- Top-level bindings are qualified, so that the printer doesn't have to pass+-- around the module name.+type Vdef = (Bool,Qual Var,Ty,Exp)++data Exp + = Var (Qual Var)+ | Dcon (Qual Dcon)+ | Lit Lit+ | App Exp Exp+ | Appt Exp Ty+ | Lam Bind Exp + | Let Vdefg Exp+ | Case Exp Vbind Ty [Alt] {- non-empty list -}+ | Cast Exp Ty+ | Note String Exp+ | External String String Ty {- target name, convention, and type -} + | DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -} + | Label String+ deriving (Show)++data Bind + = Vb Vbind+ | Tb Tbind+ deriving (Show)++data Alt + = Acon (Qual Dcon) [Tbind] [Vbind] Exp+ | Alit Lit Exp+ | Adefault Exp+ deriving (Show)++type Vbind = (Var,Ty)+type Tbind = (Tvar,Kind)++data Ty + = Tvar Tvar+ | Tcon (Qual Tcon)+ | Tapp Ty Ty+ | Tforall Tbind Ty +-- We distinguish primitive coercions+-- (represented in GHC by wired-in names), because+-- External Core treats them specially, so we have+-- to print them out with special syntax.+ | TransCoercion Ty Ty+ | SymCoercion Ty+ | UnsafeCoercion Ty Ty+ | InstCoercion Ty Ty+ | LeftCoercion Ty+ | RightCoercion Ty+ deriving (Show)++data Kind + = Klifted+ | Kunlifted+ | Kunboxed+ | Kopen+ | Karrow Kind Kind+ | Keq Ty Ty+ deriving (Show)++data Lit + = Lint Integer Ty+ | Lrational Rational Ty+ | Lchar Char Ty+ | Lstring String Ty+ deriving (Show)+ ++type Pkgname = Id+type Mname = Id+type Var = Id+type Tvar = Id+type Tcon = Id+type Dcon = Id++type Qual t = (Pkgname, Mname,t)++type Id = L.ByteString++tcArrow = (L.pack "lhc",L.pack "Lhc.Arrow",L.pack "(->)")+++\end{code}++++