/usr/share/doc/frown-doc/examples/other/Haskell/Input/Haskell.hs is in frown-doc 0.6.2.3-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | 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"
|