├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── TELL ├── examples └── Foo.hs ├── lisk.cabal └── src ├── Language └── Lisk │ └── Parser.hs └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | *.hi 3 | *.o 4 | cabal-dev 5 | src/ 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2010, Chris Done 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Chris Done nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Lisk 2 | ---- 3 | 4 | S-expression-based syntax alternative for Haskell. 5 | 6 | This software is incomplete. Don't try to use it. 7 | 8 | Latest working example: 9 | 10 | ````common-lisp 11 | {-# OPTIONS -F -pgmF lisk #-} 12 | 13 | (module demo 14 | "A demo program!") 15 | 16 | (import data.char system.io (data.map :as map)) 17 | 18 | (:: main ('io ())) 19 | (= main 20 | (do 21 | (<- line get-line) 22 | (let (= the-line line) 23 | (= some-map map.empty)) 24 | (case :do get-line 25 | ("" (put-str-ln "* * Empty!")) 26 | (x (put-str-ln x))) 27 | (foo the-line) 28 | (return ()))) 29 | 30 | (= demo 31 | (do 32 | (<- line get-line) 33 | (case :of line 34 | ("apples" (return "yum")) 35 | (anything (return "..."))))) 36 | 37 | (:: foo (-> 'string ('io ()))) 38 | (= foo x (put-str-ln (show (fib (read x))))) 39 | 40 | (= fib 0 0) 41 | (= fib 1 1) 42 | (= fib n (+ (fib (- n 1)) 43 | (fib (- n 2)))) 44 | 45 | (= fib2 46 | (case 47 | (0 0) 48 | (1 1) 49 | (n (+ (fib (- n 1)) 50 | (fib (- n 2)))))) 51 | 52 | (:: from-just (-> ('maybe a) a a)) 53 | (= from-just (('just a) b) a) 54 | (= from-just ('nothing b) b) 55 | ``` 56 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TELL: -------------------------------------------------------------------------------- 1 | exDM69 2 | Shakthi Kannan 3 | Bardur Arantsson 4 | Danny Riordan 5 | Leo Zovic 6 | Ryan Grant 7 | George Moschovitis 8 | Matt S Trout 9 | Aaron Olson 10 | Štěpán Němec 11 | -------------------------------------------------------------------------------- /examples/Foo.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -F -pgmF lisk #-} 2 | 3 | (module demo 4 | "A demo program!") 5 | 6 | (import data.char system.io (data.map :as map)) 7 | 8 | (:: main ('io ())) 9 | (= main (do (<- line get-line) 10 | (let (= the-line line) 11 | (= some-map map.empty)) 12 | (case :do get-line 13 | ("" (put-str-ln "* * Empty!")) 14 | (x (put-str-ln x))) 15 | (foo the-line) 16 | (return ()))) 17 | 18 | (= demo (do (<- line get-line) 19 | (case :of line 20 | ("apples" (return "yum")) 21 | (anything (return "..."))))) 22 | 23 | (:: foo (-> 'string ('io ()))) 24 | (= foo x (put-str-ln (show (fib (read x))))) 25 | 26 | (= fib 0 0) 27 | (= fib 1 1) 28 | (= fib n (+ (fib (- n 1)) 29 | (fib (- n 2)))) 30 | 31 | (= fib2 32 | (case 33 | (0 0) 34 | (1 1) 35 | (n (+ (fib (- n 1)) 36 | (fib (- n 2)))))) 37 | 38 | (:: from-just (-> ('maybe a) a a)) 39 | (= from-just (('just a) b) a) 40 | (= from-just ('nothing b) b) -------------------------------------------------------------------------------- /lisk.cabal: -------------------------------------------------------------------------------- 1 | -- lisk.cabal auto-generated by cabal init. For additional options, 2 | -- see 3 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. 4 | -- The name of the package. 5 | Name: lisk 6 | 7 | -- The package version. See the Haskell package versioning policy 8 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for 9 | -- standards guiding when and how versions should be incremented. 10 | Version: 0.1 11 | 12 | -- A short (one-line) description of the package. 13 | Synopsis: Lisp syntax layer for Haskell. 14 | 15 | -- A longer description of the package. 16 | -- Description: 17 | 18 | -- The license under which the package is released. 19 | License: BSD3 20 | 21 | -- The file containing the license text. 22 | License-file: LICENSE 23 | 24 | -- The package author(s). 25 | Author: Chris Done 26 | 27 | -- An email address to which users can send suggestions, bug reports, 28 | -- and patches. 29 | Maintainer: chrisdone@gmail.com 30 | 31 | -- A copyright notice. 32 | -- Copyright: 33 | 34 | Category: Language 35 | 36 | Build-type: Simple 37 | 38 | -- Extra files to be distributed with the package, such as examples or 39 | -- a README. 40 | -- Extra-source-files: 41 | 42 | -- Constraint on the version of Cabal needed to build this package. 43 | Cabal-version: >=1.2 44 | 45 | 46 | Executable lisk 47 | -- .hs or .lhs file containing the Main module. 48 | Main-is: Main.hs 49 | Hs-source-dirs: src/ 50 | 51 | -- Packages needed in order to build this package. 52 | Build-depends: base >= 4 && < 5, 53 | haskell-src-exts == 1.9.*, 54 | parsec == 3.*, 55 | mtl, 56 | regex-compat == 0.93.* 57 | 58 | -- Modules not exported by this package. 59 | -- Other-modules: 60 | 61 | -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. 62 | -- Build-tools: 63 | 64 | 65 | Library 66 | Exposed-modules: Language.Lisk.Parser 67 | Hs-source-dirs: src 68 | Build-depends: base >= 4 && < 5, 69 | haskell-src-exts == 1.9.*, 70 | parsec == 3.*, 71 | mtl, 72 | regex-compat == 0.93.* -------------------------------------------------------------------------------- /src/Language/Lisk/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, 2 | NoMonomorphismRestriction, 3 | ViewPatterns, 4 | FlexibleInstances #-} 5 | {-# OPTIONS -fno-warn-missing-signatures #-} 6 | module Language.Lisk.Parser where 7 | 8 | import Data.Maybe 9 | import Data.List 10 | import Data.Either 11 | import Control.Monad.Reader 12 | import Control.Monad.Error 13 | import Control.Arrow 14 | import Control.Applicative 15 | import Control.Monad.Identity 16 | import Data.Char 17 | import Text.Parsec hiding ((<|>),many,token,optional,spaces) 18 | import Text.Parsec.Combinator hiding (optional) 19 | import Language.Haskell.Exts.Syntax 20 | import Language.Haskell.Exts.Pretty 21 | import qualified Language.Haskell.Exts.Parser as P 22 | (parseExp,parse,parseWithMode,defaultParseMode,ParseMode(..),ParseResult(..)) 23 | import qualified Language.Haskell.Exts.Extension as P 24 | 25 | type LP = Parsec String () 26 | 27 | parseLiskExp = parse liskExp 28 | 29 | printLiskToHaskell = prettyPrint 30 | 31 | parseLisk = parse (spaces *> liskModule <* spaces) 32 | 33 | printLiskFragment p = either (putStrLn.show) (putStrLn.prettyPrint) . parse p "" 34 | 35 | printLisk str = 36 | case parse liskModule "" str of 37 | Left e -> error $ show e ++ suggest 38 | Right ex -> putStrLn $ prettyPrint ex 39 | 40 | liskModule = do 41 | loc <- getLoc 42 | string "(" 43 | symbolOf "module" "module" 44 | spaces1 45 | name <- liskModuleName 46 | docstring <- try (spaces1 *> liskString) <|> return (String "") 47 | string ")" 48 | importDecls <- concat <$> many (try $ spaces *> liskImportDecl) 49 | spaces 50 | decls <- many $ try $ spaces *> liskDecl 51 | spaces 52 | eof 53 | return $ Module loc name [] Nothing Nothing importDecls decls 54 | 55 | symbolOf = string 56 | 57 | liskDecl = try liskTypeInsDecl 58 | <|> try liskDataDecl 59 | <|> try liskTypeDecl 60 | <|> try liskTypeSig 61 | <|> try liskFunBind 62 | <|> liskPatBind 63 | 64 | liskTypeInsDecl = parens $ do 65 | loc <- getLoc 66 | string "instance" "type instance e.g. (instance ('show a) (show x \"foo\"))" 67 | spaces1 68 | (name,vars) <- parens $ do name <- liskQName 69 | spaces1 70 | vars <- many1 $ spaces *> liskTyVar 71 | return (name,vars) 72 | decls <- many ((InsDecl <$> (try $ spaces *> liskDecl)) "method declaration e.g. (= x y)") 73 | return $ InstDecl loc [] name vars decls 74 | 75 | liskTypeDecl = parens $ do 76 | loc <- getLoc 77 | string "type" 78 | spaces1 79 | ident <- liskName 80 | spaces1 81 | typ <- liskType 82 | return $ TypeDecl loc ident [] typ 83 | 84 | liskDataDecl = parens $ do 85 | loc <- getLoc 86 | ty <- (<|>) (string "data" "data declaration e.g. (data ('maybe a) ('just a) 'nothing)") 87 | (string "newtype" "newtype declaration e.g. (newtype 'x 'x 'int)") 88 | spaces1 89 | (vars,name) <- ((,) [] <$> liskName) <|> 90 | parens (do name <- liskName 91 | vars <- many1 $ spaces *> liskName 92 | return (map UnkindedVar vars,name)) 93 | spaces1 94 | conts <- many $ try $ spaces *> liskQualConDecl 95 | let dat | ty == "data" = DataType 96 | | otherwise = NewType 97 | context = [] -- TODO: context 98 | derivin <- (spaces1 *> liskDerivings) <|> pure [] 99 | return $ DataDecl loc dat context name vars conts derivin 100 | 101 | liskDerivings = do 102 | string ":deriving" "deriving clause e.g. :deriving ('read 'show) or \ 103 | \:deriving (('monad-state 'io))" 104 | spaces1 105 | parens $ many $ try $ spaces *> (liskDeriving <|> liskDerivingNoParams) 106 | 107 | liskDerivingNoParams = do 108 | name <- liskQName 109 | return $ (name,[]) 110 | 111 | liskDeriving = parens $ do 112 | name <- liskQName 113 | typs <- many $ spaces *> liskType 114 | return $ (name,typs) 115 | 116 | liskQualConDecl = try liskRecDecl <|> liskConDecl 117 | 118 | liskConDecl = liskConDeclName <|> liskConDeclParams 119 | 120 | liskConDeclParams = parens $ do 121 | loc <- getLoc 122 | name <- liskName 123 | spaces1 124 | ps <- many $ spaces *> liskType 125 | return $ QualConDecl loc ([]::[TyVarBind]) ([]::Context) $ 126 | ConDecl name $ map UnBangedTy ps 127 | 128 | liskConDeclName = do 129 | loc <- getLoc 130 | name <- liskName 131 | return $ QualConDecl loc ([]::[TyVarBind]) ([]::Context) $ 132 | ConDecl name [] 133 | 134 | liskRecDecl = parens $ do 135 | loc <- getLoc 136 | name <- liskName 137 | spaces1 138 | string ":fields" 139 | spaces1 140 | fields <- parens $ many1 $ spaces *> liskRecDeclField 141 | pure $ QualConDecl loc ([]::[TyVarBind]) ([]::Context) $ 142 | RecDecl name fields 143 | 144 | liskRecDeclField = parens $ do 145 | name <- liskName 146 | spaces1 147 | ty <- liskType 148 | pure ([name],UnBangedTy ty) 149 | 150 | liskTypeSig = parens $ do 151 | loc <- getLoc 152 | symbolOf "::" "type signature e.g. (:: x 'string)" 153 | spaces1 154 | idents <- pure <$> liskIdent <|> 155 | parens (sepBy1 liskIdent spaces1) 156 | spaces1 157 | typ <- liskType 158 | return $ TypeSig loc idents typ 159 | 160 | liskType = try liskTyCon <|> try liskTyVar <|> 161 | try liskForall <|> 162 | liskTyApp 163 | 164 | liskForall = parens $ do 165 | string "=>" 166 | spaces1 167 | context <- pure <$> liskConstraint <|> many1 (try $ spaces *> liskConstraint) 168 | spaces1 169 | typ <- liskType 170 | return $ TyForall Nothing context typ 171 | 172 | liskConstraint = parens $ do 173 | class' <- liskQName 174 | spaces1 175 | vars <- sepBy1 liskTyVar spaces1 176 | return $ ClassA class' vars 177 | 178 | liskTyApp = parens $ do 179 | op <- liskType 180 | spaces1 181 | args <- sepBy1 liskType spaces1 182 | let op' = 183 | case op of 184 | TyCon (Special (TupleCon b n)) -> TyCon $ Special $ TupleCon b $ length args 185 | _ -> op 186 | case op of 187 | TyCon o@(Special FunCon) -> 188 | return $ TyParen $ foldl1 (flip TyInfix o) args 189 | _ -> return $ TyParen $ foldl TyApp op' args 190 | 191 | liskTyCon = TyCon <$> liskQName 192 | 193 | liskTyVar = TyVar <$> liskName 194 | 195 | liskPatBind = parens $ do 196 | loc <- getLoc 197 | symbolOf "=" "pattern binding e.g. (= hello-world \"Hello, World!\")" 198 | spaces1 199 | pat <- liskPat 200 | typ <- return Nothing -- liskType -- TODO 201 | spaces1 202 | rhs <- liskRhs 203 | binds <- liskBinds 204 | return $ PatBind loc pat Nothing rhs binds 205 | 206 | liskFunBind = FunBind <$> many1 (try $ spaces *> liskMatch) 207 | 208 | liskMatch = parens $ do 209 | loc <- getLoc 210 | symbolOf "=" "function binding e.g. (= id (x) x)" 211 | spaces1 212 | name <- liskName 213 | spaces1 214 | pats <- (pure <$> try liskSimplePat) <|> parens (sepBy1 liskPat spaces1) 215 | typ <- return Nothing -- liskType -- TODO 216 | spaces1 217 | rhs <- liskRhs 218 | binds <- liskBinds 219 | return $ Match loc name pats typ rhs binds 220 | 221 | liskBinds = try liskBDecls <|> liskIPBinds 222 | 223 | liskBDecls = BDecls <$> many (spaces *> decls) where 224 | decls = try liskTypeSig <|> try liskFunBind <|> liskPatBind 225 | 226 | liskIPBinds = IPBinds <$> pure [] -- TODO 227 | 228 | liskSimplePat = liskPVar 229 | <|> liskPLit 230 | <|> liskPatTypeSig 231 | 232 | liskPat = liskPVar 233 | <|> try liskPFieldWildCard 234 | <|> liskWildCard 235 | <|> liskPLit 236 | <|> try liskPatTypeSig 237 | <|> try liskPTuple 238 | <|> liskPList 239 | <|> liskPApp 240 | -- TODO: There are a lot more. 241 | 242 | liskPFieldWildCard = parens $ do 243 | name <- liskQName 244 | spaces1 245 | string ".." 246 | return $ PRec name [PFieldWildcard] 247 | 248 | liskPList = do 249 | char '[' 250 | els <- many $ try $ spaces *> liskPat 251 | char ']' 252 | return $ PList els 253 | 254 | liskPatTypeSig = fmap PParen $ parens $ do 255 | loc <- getLoc 256 | string "::" 257 | spaces1 258 | pat <- liskPat 259 | spaces1 260 | typ <- liskType 261 | return $ PatTypeSig loc pat typ 262 | 263 | liskPTuple = parens $ do 264 | char ',' 265 | args <- many1 $ spaces1 *> liskPat 266 | return $ PTuple $ args 267 | 268 | liskPApp = fmap PParen $ parens $ do 269 | op <- liskQName -- TODO: Restrict to constructor 270 | args <- many1 $ spaces1 *> liskPat 271 | return $ PApp op $ args 272 | 273 | liskPLit = PLit <$> liskLit 274 | 275 | liskRhs = liskUnguardedRhs 276 | 277 | liskUnguardedRhs = UnGuardedRhs <$> liskExp 278 | 279 | -- TODO 280 | liskExp = try liskVar 281 | <|> try liskExpTypeSig 282 | <|> Lit <$> try liskLit 283 | <|> try liskList 284 | <|> try liskUnit 285 | <|> try liskLet 286 | <|> try liskDo 287 | <|> try liskLambda 288 | <|> try liskCase 289 | <|> try liskApp 290 | <|> Paren <$> parens liskExp 291 | 292 | liskExpTypeSig = parens $ do 293 | loc <- getLoc 294 | string "::" "type signature e.g. (:: x 'int)" 295 | spaces1 296 | e <- liskExp 297 | spaces1 298 | t <- liskType 299 | return $ ExpTypeSig loc e t 300 | 301 | liskList = do 302 | char '[' 303 | els <- many $ try $ spaces *> liskExp 304 | char ']' 305 | return $ List els 306 | 307 | liskLet = parens $ do 308 | loc <- getLoc 309 | string "let" "let expression e.g. (let ((= x 1)) x)" 310 | spaces1 311 | binds <- parens $ liskBinds 312 | spaces1 313 | exp <- liskExp 314 | return $ Let binds exp 315 | 316 | liskCase = parens $ do 317 | loc <- getLoc 318 | string "case" ("case expression e.g. (case (0 0)), (case :of x (0 0))" 319 | ++ ", (case :do get-line (\"foo\" True))") 320 | value <- optional $ try $ spaces1 *> char ':' *> 321 | (Left <$> liskCaseOf <|> Right <$> liskCaseDo) 322 | spaces1 323 | alts <- sepBy1 (try liskAlt) spaces1 324 | case value of 325 | Just e -> case e of 326 | Left of' -> return $ Case of' alts 327 | Right do' -> do 328 | sym <- genSym 329 | return $ (Paren (InfixApp do' 330 | (QVarOp (UnQual (Symbol ">>="))) 331 | (Lambda loc [PVar sym] 332 | (Case (Var $ UnQual sym) alts)))) 333 | Nothing -> do 334 | sym <- genSym 335 | return $ Lambda loc [PVar sym] 336 | $ Case (Var $ UnQual sym) alts 337 | 338 | liskAlt = parens $ do 339 | loc <- getLoc 340 | pat <- liskPat 341 | spaces1 342 | alts <- liskGuardedAlts 343 | binds <- pure (BDecls []) 344 | return $ Alt loc pat alts binds 345 | 346 | liskGuardedAlts = try liskGuardUnless <|> try liskGuardedAltsList <|> liskUnGuardedAlt 347 | 348 | liskGuardUnless = do 349 | string ":unless" "unless clause e.g. (xs :unless (null xs) (map (+ 1) xs))" 350 | spaces1 351 | alt <- liskGuardedAlt 352 | let GuardedAlt loc [Qualifier stmts] exp = alt 353 | alt' = GuardedAlt loc [Qualifier $ App (Var (UnQual (Symbol "not"))) 354 | stmts] 355 | exp 356 | return $ GuardedAlts [alt'] 357 | 358 | liskGuardedAltsList = do 359 | string ":when" "when clause e.g. (xs :when ((null xs) []))" 360 | spaces1 361 | alts <- many1 $ try $ spaces *> parens liskGuardedAlt 362 | return $ GuardedAlts alts 363 | 364 | liskGuardedAlt = do 365 | loc <- getLoc 366 | quals <- pure <$> liskQualifier 367 | spaces1 368 | exp <- liskExp 369 | return $ GuardedAlt loc quals exp 370 | 371 | liskUnGuardedAlt = UnGuardedAlt <$> liskExp 372 | 373 | genSym = do 374 | loc <- getLoc 375 | return $ Ident $ 376 | "_lisk_" ++ show (srcLine loc) ++ "_" ++ show (srcColumn loc) 377 | 378 | liskCaseOf = do 379 | string "of" 380 | spaces1 381 | liskExp 382 | 383 | liskCaseDo = do 384 | string "do" 385 | spaces1 386 | liskExp 387 | 388 | liskLambda = parens $ do 389 | loc <- getLoc 390 | string "fn" "fn expression e.g. (fn (x y) (+ x y))" 391 | spaces1 392 | pats <- (try $ pure <$> liskSimplePat) <|> parens (many1 (spaces *> liskPat)) 393 | spaces1 394 | e <- liskExp 395 | return $ Lambda loc pats e 396 | 397 | liskUnit = parens $ return $ Con (Special UnitCon) 398 | 399 | liskDo = parens $ do 400 | string "do" "do expression e.g. (do (<- x y) (return x))" 401 | spaces1 402 | stmts <- many $ spaces *> liskStmt 403 | return $ Do stmts 404 | 405 | liskStmt = try liskGenerator <|> 406 | try liskLetStmt <|> 407 | liskQualifier -- TODO: There are more. 408 | 409 | liskQualifier = Qualifier <$> liskExp 410 | 411 | liskGenerator = parens $ do 412 | loc <- getLoc 413 | string "<-" "do binding e.g. (<- x (return k))" 414 | spaces1 415 | pat <- liskPat "binding pattern e.g. (<- ('just x) (return 1))" 416 | spaces1 417 | e <- liskExp 418 | return $ Generator loc pat e 419 | 420 | liskLetStmt = parens $ do 421 | loc <- getLoc 422 | string "let" "do let e.g. (let (= x 2))" 423 | spaces1 424 | binds <- liskBinds 425 | return $ LetStmt binds 426 | 427 | liskApp = try liskTupleApp <|> try liskOpApp <|> try liskIdentApp <|> liskOpPartial 428 | 429 | liskTupleApp = parens $ do 430 | string "," 431 | args <- (spaces1 *> sepBy1 liskExp spaces1) <|> pure [] 432 | let op = Var $ Special $ TupleCon Boxed $ max 2 (length args) 433 | paren | null args = id 434 | | otherwise = Paren 435 | return $ paren $ foldl App op $ args 436 | 437 | liskIdentApp = parens $ do 438 | op <- liskExp 439 | spaces1 440 | args <- sepBy1 liskExp spaces1 441 | return $ Paren $ foldl App op $ args 442 | 443 | liskOpApp = parens $ do 444 | op <- QVarOp <$> liskOp 445 | spaces1 446 | args <- (:) <$> (liskExp <* spaces) <*> sepBy1 liskExp spaces1 447 | return $ Paren $ foldl1 (flip InfixApp op) args 448 | 449 | liskOpPartial = parens $ do 450 | op <- Var <$> liskOp 451 | spaces1 452 | e <- liskExp 453 | return $ App op e 454 | 455 | liskOp = UnQual . Symbol <$> 456 | many1 (oneOf ".*-+/\\=<>$#&:") 457 | 458 | liskLit = liskChar <|> try liskString <|> liskInt 459 | 460 | liskChar = Char <$> (string "\\" *> (space <|> newline <|> noneOf "\n \t")) 461 | where space = const ' ' <$> string "Space" 462 | <|> const '\n' <$> string "Newline" 463 | 464 | liskString = do 465 | strRep <- char '\"' *> (concat <$> many liskStringSeq) <* char '\"' 466 | case P.parseExp $ "\"" ++ strRep ++ "\"" of 467 | P.ParseOk (Lit s@String{}) -> return s 468 | P.ParseFailed _ msg -> parserFail msg 469 | where liskStringSeq = ("\\"++) <$> (char '\\' *> (pure <$> noneOf "\n")) 470 | <|> pure <$> noneOf "\n\"" 471 | 472 | liskInt = Int <$> (read <$> many1 digit) 473 | 474 | liskPVar = PVar <$> liskName 475 | 476 | liskQName = try liskSpecial <|> try liskQual <|> try liskUnQual 477 | 478 | liskWildCard = pure (PWildCard) <* char '_' 479 | 480 | liskQual = do 481 | prime <- isJust <$> optional (string "'") 482 | word <- liskModuleName "module name e.g. data.char" 483 | let (ModuleName word') = word 484 | (name,mod) = (downFirst . reverse *** reverse . drop 1) $ 485 | span (/='.') $ reverse word' 486 | downFirst (x:xs) | not prime = toLower x : xs 487 | downFirst xs = xs 488 | return $ if null mod 489 | then UnQual (Ident name) 490 | else Qual (ModuleName mod) (Ident name) 491 | 492 | liskUnQual = UnQual <$> liskName 493 | 494 | liskSpecial = Special <$> spec where 495 | spec = string "()" *> pure UnitCon 496 | <|> string "[]" *> pure ListCon 497 | <|> string ":" *> pure Cons 498 | <|> string "->" *> pure FunCon 499 | <|> do cs <- many1 (char ',') 500 | pure (TupleCon Boxed (1 + length cs)) 501 | 502 | liskName = try liskIdent <|> liskSymbol 503 | 504 | liskVar = Var <$> (liskOp <|> liskQName) 505 | 506 | liskIdent = Ident . hyphenToCamelCase . colonToConsTyp <$> ident where 507 | ident = ((++) <$> (string "'" <|> pure "") 508 | <*> many1 liskIdentifierToken) 509 | 510 | colonToConsTyp ('\'':x:xs) = toUpper x : xs 511 | colonToConsTyp xs = xs 512 | 513 | liskSymbol = Symbol <$> many1 liskIdentifierToken 514 | 515 | liskImportDecl = parens $ do 516 | symbolOf "import" "import list e.g. (import prelude data.list (system.char is-upper to-lower))" 517 | spaces1 518 | sepBy1 liskImportDeclModule spaces1 519 | 520 | liskImportDeclModule = 521 | liskImportDeclModuleName <|> liskImportDeclModuleSpec 522 | 523 | liskImportDeclModuleSpec = parens $ do 524 | name <- liskImportDeclModuleName 525 | qualification <- optional $ spaces1 *> string ":as" *> spaces1 *> 526 | liskModuleName 527 | return name { importQualified = isJust qualification 528 | , importAs = qualification } 529 | 530 | liskImportDeclModuleName = do 531 | loc <- getLoc 532 | name <- liskModuleName 533 | return $ ImportDecl { 534 | importLoc = loc 535 | , importModule = name 536 | , importQualified = False 537 | , importSrc = False 538 | , importPkg = Nothing 539 | , importAs = Nothing 540 | , importSpecs = Nothing 541 | } 542 | 543 | liskModuleName = ( "module name (e.g. `module.some-name')") $ do 544 | parts <- sepBy1 modulePart (string ".") 545 | return $ ModuleName $ intercalate "." parts 546 | where modulePart = format <$> many1 liskIdentifierToken 547 | format = hyphenToCamelCase . upperize 548 | upperize (x:xs) = toUpper x : xs 549 | 550 | liskDefIdentifier = do 551 | ident <- many1 liskIdentifierToken 552 | return $ Ident ident 553 | 554 | liskIdentifierToken = letter <|> digit <|> oneOf "-" 555 | 556 | hyphenToCamelCase ('-':'-':xs) = hyphenToCamelCase ('-':xs) 557 | hyphenToCamelCase ('-':x:xs) = toUpper x : hyphenToCamelCase xs 558 | hyphenToCamelCase ('-':xs) = hyphenToCamelCase xs 559 | hyphenToCamelCase (x:xs) = x : hyphenToCamelCase xs 560 | hyphenToCamelCase [] = [] 561 | 562 | getLoc = posToLoc <$> getPosition where 563 | posToLoc pos = 564 | SrcLoc { srcFilename = sourceName pos 565 | , srcLine = sourceLine pos 566 | , srcColumn = sourceColumn pos 567 | } 568 | 569 | parens = between (char '(') (char ')') 570 | 571 | suggest = "\n(are you trying to use not-currently-supported syntax?)" 572 | 573 | spaces = do 574 | (many1 space *> spaces) 575 | <|> ((string "--" <|> string ";;") *> manyTill anyChar ((newline *> pure ()) <|> eof) *> spaces) 576 | <|> pure () 577 | 578 | spaces1 = do 579 | space 580 | spaces 581 | 582 | spaced1 p = (:) <$> p <*> (try (spaces1 *> spaced p) <|> pure []) 583 | 584 | spaced p = go where 585 | go = do x <- Just <$> p <|> pure Nothing 586 | case x of 587 | Just x' -> do 588 | a <- spaces *> go 589 | pure (x':a) 590 | Nothing -> pure [] 591 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Language.Lisk.Parser 5 | import System.Environment 6 | import System.Exit 7 | import System.IO 8 | import Text.Parsec 9 | import Text.Parsec.Error 10 | import Text.Parsec.Pos 11 | import Text.Regex 12 | 13 | main = do 14 | (original:input:output:_) <- getArgs 15 | str <- readFile input 16 | case parseLisk original (unlines . ("":) . drop 1 . lines $ str) of 17 | Left err -> do hPutStr stderr $ showError err 18 | exitWith $ ExitFailure 1 19 | Right src -> writeFile output $ printLiskToHaskell src 20 | where showError err = line ++ msg ++ suggest where 21 | line = format . unlines . take 1 . lines $ e 22 | msg = (unlines . drop 1 . lines $ e) 23 | e = show err 24 | 25 | format = flip (subRegex (mkRegex r)) "\\1:\\2:\\3:" where 26 | r = "^\"([^\"]+)\" \\(line ([0-9]+), column ([0-9]+)\\):$" 27 | 28 | 29 | bothOn f g x y = f (g x y) (g y x) 30 | --------------------------------------------------------------------------------