module Haskell -- ( module Haskell, module Atom ) where import Base import Lexer2 import Atom hiding ( string ) import qualified Atom import Prettier import Char import Prelude hiding ( concat ) type Quoted = [Token] type Type = Expr type Pat = Expr data Expr = Var Ident | Con Ident | Literal Literal | Tuple [Expr] | List [Expr] | Case Expr [(Pat, Expr)] | Let [Decl] Expr | Fun [Pat] Expr | App Expr Expr | Infix Expr Ident Expr | Quoted Quoted | As Ident Pat | Guard Pat Expr | TypeOf Quoted Quoted -- deprecated deriving (Eq, Ord, Show) instance Pretty Expr where prettyPrec d (Var i) = prettyPrec d i prettyPrec d (Con i) = prettyPrec d i prettyPrec d (Literal l) = prettyPrec d l prettyPrec _d (Tuple es) = parens (sepBy (char ',' <> nl) es) prettyPrec _d (List es) = brackets (sepBy (char ',' <> nl) es) prettyPrec d (Case e cs) = condParens (d > 1) $ block 4 (string "case " <> nest 5 (pretty e) <> string " of" <+> string "{" <> nl <> intersperse sep [ block 4 (pretty p <> nl <> string "->" <> sp <> nest 3 (pretty e')) | (p, e') <- cs ] <+> string "}") where sep = string ";" <> nl prettyPrec d (Let ds e) = condParens (d > 1) $ group (string "let " <> string "{" <> nest 6 (nl <> sepBy sep ds) <> nest 4 (nl <> string "}") <> nl <> string "in" <> nest 3 (sp <> pretty e)) where sep = string ";" <> nl prettyPrec d (Fun ps e) = condParens (d > 1) $ block 4 (string "\\" <> nl <> prettyMany ps <> nl <> string "->" <> nl <> pretty e) prettyPrec d (App e1 e2) = condParens (d > 9) $ block 4 (prettyPrec 9 e1 <> nl <> prettyPrec 10 e2) prettyPrec d (Infix e1 op e2) = condParens (d > 8) $ block 4 (prettyPrec 9 e1 <> nl <> pretty op <> nl <> prettyPrec rprec e2) where rprec = if op == ident "->" then 8 else 9 prettyPrec _d (As i p) = block 4 (prettyPrec 10 i <> string "@" -- TODO: parens <> nest (length (Atom.string i) + 1) (prettyPrec 10 p)) prettyPrec _d (Guard p e) = block 4 (pretty p <+> string "|" <+> pretty e) {- prettyPrec d (TypeOf _ _) = string "-" prettyPrec d (Quoted _) = string "-" -} prettyPrec d (TypeOf ts us) = condParens (d > 9) $ block 4 (quote ts <> nl <> string "::" <> nl <> quote us) prettyPrec _d (Quoted [t]) = condParens (not (isVarid t || isConid t)) $ string (toString t) prettyPrec _d (Quoted ts) = parens (concat [ string (toString t) | t <- ts ]) con, var :: String -> Expr con (c : s) = Con (ident (toUpper c : s)) con _ = impossible "Haskell.con" var (c : s) = Var (ident (toLower c : s)) var _ = impossible "Haskell.var" stringLiteral :: String -> Expr stringLiteral s = Literal (stringLit s) tuple :: [Expr] -> Expr tuple [e] = e tuple es = Tuple es hsInfix :: Expr -> String -> Expr -> Expr hsInfix e1 s e2 = Infix e1 (ident s) e2 quote :: [Token] -> Doc quote ts = concat [ string (toString t) | t <- ts ] data Decl = DataDecl Type [(Ident, [Type])] | TypeDecl Type Type | FunBind Expr Expr | Sig [Ident] Type | Empty | AComment [String] | Raw String deriving (Eq, Ord, Show) instance Pretty Decl where prettyPrec _d (DataDecl t cs) = string "data" <+> nest 5 (pretty t) <> block 4 (nl <> equals <+> intersperse (nl <> string "|" <> sp) (map prettyConstruct cs)) prettyPrec _d (TypeDecl t t') = string "type" <+> nest 5 (pretty t) <> block 4 (nl <> equals <+> pretty t') prettyPrec _d (FunBind lhs rhs) = pretty lhs <> block 4 (nl <> equals <+> nest 2 (pretty rhs)) prettyPrec _d (Sig ids t) = block 4 (intersperse (string "," <> nl) (map pretty ids) <> nl <> string "::" <> sp <> pretty t) prettyPrec _d Empty = empty prettyPrec _d (AComment ss) = group (string "{-" <> intersperse nl [ nest 2 (string s) | s <- ss ] <> string "-}") prettyPrec _d (Raw s) = string s prettyConstruct :: (Pretty a) => (Ident, [a]) -> Doc prettyConstruct (c, []) = pretty c prettyConstruct (c, ts) = block 5 (pretty c <> nl <> prettyMany ts) local :: [Decl] -> Expr -> Expr local [] e = e local ds e = Let ds e anon :: Pat anon = var "_" hsUndefined, hsReturn, hsFail, hsPutStrLn, hsShow, hsNil, hsHead, hsTail :: Expr hsUndefined = var "undefined" hsReturn = var "return" hsFail = var "fail" hsPutStrLn = var "putStrLn" hsShow = var "show" hsNil = con "[]" hsHead = var "head" hsTail = var "tail" infix 7 <=>> (<=>>) :: Expr -> Expr -> Expr e1 <=>> e2 = hsInfix e1 "=>" e2 infixr 8 <->> (<->>) :: [Expr] -> Expr -> Expr [] <->> e' = e' (e : es) <->> e' = hsInfix e "->" (es <->> e') infixl 9 <$> (<$>) :: Expr -> [Expr] -> Expr e <$> es = foldl App e es -- e <$> [] = e -- e <$> es = apply e es infixr 5 <:> (<:>) :: Expr -> Expr -> Expr e1 <:> e2 = hsInfix e1 ":" e2 infixr 5 <++> (<++>) :: Expr -> Expr -> Expr e1 <++> e2 = hsInfix e1 "++" e2 infixl 1 <>>>, <>>=> (<>>>), (<>>=>) :: Expr -> Expr -> Expr e1 <>>> e2 = hsInfix e1 ">>" e2 e1 <>>=> e2 = hsInfix e1 ">>=" e2 infixr 3 <&&> (<&&>) :: Expr -> Expr -> Expr e1 <&&> e2 = hsInfix e1 "&&" e2 funbind :: Expr -> Expr -> Decl funbind lhs rhs = FunBind (guard lhs' gs) rhs where (lhs', gs) = guards lhs switch :: Expr -> [(Pat, Expr)] -> Expr switch e cs = Case e [ (guard p' gs, e') | (p, e') <- cs, let (p', gs) = guards p ] guards :: Pat -> (Pat, [Expr]) guards (Var s) = (Var s, []) guards (Con s) = (Con s, []) guards (Literal s) = (Literal s, []) guards (Tuple ps) = (Tuple (map fst ps'), concatMap snd ps') where ps' = map guards ps guards (List ps) = (List (map fst ps'), concatMap snd ps') where ps' = map guards ps guards (App p q) = (App p' q', gp ++ gq) where (p', gp) = guards p (q', gq) = guards q guards (As x p) = (As x p', gp) where (p', gp) = guards p guards (Infix p x q) = (Infix p' x q', gp ++ gq) where (p', gp) = guards p (q', gq) = guards q guards (Guard p q) = (p, [App q p]) -- TODO: `|p|' should be an expression -- where [Varid s] = filter (not . isWhite) qs -- Hack: should introduce an as-pattern with a fresh variable guards (Quoted hs) = (Quoted hs, []) guards e = impossible ("Haskell.guards: " ++ show e) guard :: Expr -> [Expr] -> Expr guard e [] = e guard e gs = Guard e (foldr1 (<&&>) gs) equals :: Doc equals = string "=" sepBy :: (Pretty a) => Doc -> [a] -> Doc sepBy sep as = intersperse sep (map pretty as) prettyMany :: (Pretty a) => [a] -> Doc prettyMany as = intersperse nl (map (prettyPrec 10) as) replace :: Expr -> Expr -> Expr replace _e (Var s) = Var s replace _e (Con s) = Con s replace _e (Literal s) = Literal s replace e (Tuple ps) = Tuple (map (replace e) ps) replace e (List ps) = List (map (replace e) ps) replace e (App p q) = App (replace e p) (replace e q) replace e (Guard p q) = Guard (replace e p) q replace e (TypeOf _ _) = e replace e (Quoted _) = e replace _ _ = impossible "Haskell.replace" combine :: Expr -> [Expr] -> Expr combine p vs = fst (combine' p vs) combine' :: Expr -> [Expr] -> (Expr, [Expr]) combine' (Var s) vs = (Var s, vs) combine' (Con s) vs = (Con s, vs) combine' (Literal s) vs = (Literal s, vs) combine' (Tuple ps) vs = let (ps', vs') = combineMany' ps vs in (Tuple ps', vs') combine' (List ps) vs = let (ps', vs') = combineMany' ps vs in (List ps', vs') combine' (App p q) vs = let (p', vs1) = combine' p vs (q', vs2) = combine' q vs1 in (App p' q', vs2) combine' (Guard p q) vs = let (p', vs') = combine' p vs in (Guard p' q, vs') combine' (TypeOf _ _) vs = (head vs, tail vs) combine' (Quoted _) vs = (head vs, tail vs) combine' _ _ = impossible "Haskell.combine'" combineMany' :: [Expr] -> [Expr] -> ([Expr], [Expr]) combineMany' [] vs = ([], vs) combineMany' (p : ps) vs = let (p', vs1) = combine' p vs (ps', vs2) = combineMany' ps vs1 in (p' : ps', vs2) quotes :: Pat -> [Expr] quotes (Var _s) = [] quotes (Con _s) = [] quotes (Literal _s) = [] quotes (Tuple ps) = concatMap quotes ps quotes (List ps) = concatMap quotes ps quotes (App p q) = quotes p ++ quotes q quotes (Guard p _q) = quotes p quotes (Quoted hs) = [Quoted hs] quotes _ = impossible "Haskell.quotes"