Updated the example to semi-iso 0.4

This commit is contained in:
Paweł Nowak 2014-11-23 13:39:58 +01:00
parent bebffd3add
commit dbff80580c
2 changed files with 53 additions and 19 deletions

64
Main.hs
View File

@ -3,14 +3,17 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
import Control.Applicative import Control.Applicative
import Control.Lens.Cons
import Control.Lens.SemiIso import Control.Lens.SemiIso
import Control.Lens.TH import Control.Lens.TH
import qualified Data.Attoparsec.Text as AP import qualified Data.Attoparsec.Text as AP
import Data.Char import Data.Char
import Data.Scientific (Scientific)
import Data.SemiIsoFunctor import Data.SemiIsoFunctor
import Data.Syntax (Syntax) import Data.Syntax (Syntax)
import qualified Data.Syntax as S import qualified Data.Syntax as S
import qualified Data.Syntax.Attoparsec.Text as S import qualified Data.Syntax.Attoparsec.Text as S
import Data.Syntax.Char (SyntaxChar)
import qualified Data.Syntax.Char as S import qualified Data.Syntax.Char as S
import qualified Data.Syntax.Combinator as S import qualified Data.Syntax.Combinator as S
import qualified Data.Syntax.Pretty as S import qualified Data.Syntax.Pretty as S
@ -18,37 +21,68 @@ import Data.Text (Text)
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Text.PrettyPrint as P import qualified Text.PrettyPrint as P
-- | A simple untyped lambda calculus. -- A simple untyped lambda calculus.
data Literal = LitStr Text
| LitNum Scientific
deriving (Show)
$(makePrisms ''Literal)
data AST = Var Text data AST = Var Text
| Lit Literal
| App AST AST | App AST AST
| Abs Text AST | Abs Text AST
| Let Text AST AST
deriving (Show) deriving (Show)
$(makePrisms ''AST) $(makePrisms ''AST)
-- | A variable name. -- | A variable name.
name :: Syntax syn Text => syn Text name :: Syntax syn Text => syn Text
name = S.takeWhile1 isAlphaNum name = _Cons /$/ S.satisfy isAlpha /*/ S.takeWhile isAlphaNum
-- | A quoted string.
quoted :: SyntaxChar syn seq => syn seq
quoted = S.char '"' */ S.takeTill (=='"') /* S.char '"'
-- | Encloses a symbol in parentheses. -- | Encloses a symbol in parentheses.
parens :: Syntax syn Text => syn a -> syn a parens :: SyntaxChar syn seq => syn a -> syn a
parens m = S.char '(' */ S.spaces_ */ m /* S.spaces_ /* S.char ')' parens m = S.char '(' */ S.spaces_ */ m /* S.spaces_ /* S.char ')'
-- | An atom is a variable or an expression in parentheses. -- | A literal.
atom :: Syntax syn Text => syn AST literal :: SyntaxChar syn Text => syn Literal
atom = _Var /$/ name literal = _LitNum /$/ S.scientific
/|/ _LitStr /$/ quoted
-- | An atom is a variable, literal or an expression in parentheses.
atom :: SyntaxChar syn Text => syn AST
atom = _Lit /$/ literal
/|/ _Var /$/ name
/|/ parens expr /|/ parens expr
-- | Parsers a list of applications. -- | Parses a list of atoms and folds them with the _App prism.
apps :: Syntax syn Text => syn AST apps :: SyntaxChar syn Text => syn AST
apps = bifoldl1 (attemptAp_ _App) /$/ S.sepBy1 atom S.spaces1 apps = bifoldl1 _App /$/ S.sepBy1 atom S.spaces1
-- | An expression of our lambda calculus. -- | An expression of our lambda calculus.
expr :: Syntax syn Text => syn AST --
expr = _Abs /$/ S.char '\\' /* S.spaces_ -- Thanks to 'tuple-morph' we don't have to worry about /* and */ here.
*/ name /* S.spaces -- Tuples are reassociated and units are removed by the 'morphed'
/* S.string "->" /* S.spaces -- isomorphism (applied in /$~ operator).
expr :: SyntaxChar syn Text => syn AST
expr = _Abs /$~ S.char '\\' /*/ S.spaces_
/*/ name /*/ S.spaces
/*/ S.string "->" /*/ S.spaces
/*/ expr /*/ expr
/|/ _Let /$~ S.string "let" /*/ S.spaces1
/*/ name /*/ S.spaces
/*/ S.char '=' /*/ S.spaces
/*/ expr /*/ S.spaces1
/*/ S.string "in" /*/ S.spaces1
/*/ expr
/|/ apps /|/ apps
main :: IO () main :: IO ()
@ -58,7 +92,7 @@ main = do
-- Try to parse it. -- Try to parse it.
case AP.parseOnly (S.getParser expr <* AP.skipSpace <* AP.endOfInput) t of case AP.parseOnly (S.getParser expr <* AP.skipSpace <* AP.endOfInput) t of
Left err -> putStrLn err Left err -> putStrLn err
Right ast -> do Right ast -> do
-- If parsing succeeded print the AST. -- If parsing succeeded print the AST.
print ast print ast
@ -66,7 +100,7 @@ main = do
-- Try to pretty print it. -- Try to pretty print it.
-- (Printing cannot really fail in this example) -- (Printing cannot really fail in this example)
case S.runPrinter expr ast of case S.runPrinter expr ast of
Left err -> putStrLn err Left err -> putStrLn err
Right doc -> putStrLn (P.render doc) Right doc -> putStrLn (P.render doc)
return () return ()

View File

@ -1,5 +1,5 @@
name: syntax-example name: syntax-example
version: 0.2.0.0 version: 0.3.0.0
synopsis: Example application using syntax, a library for abstract syntax descriptions. synopsis: Example application using syntax, a library for abstract syntax descriptions.
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
@ -16,7 +16,7 @@ source-repository head
executable syntax-example executable syntax-example
main-is: Main.hs main-is: Main.hs
build-depends: base >= 4 && < 5, lens, semi-iso >= 0.3, build-depends: base >= 4 && < 5, lens, semi-iso >= 0.4,
syntax >= 0.1.1, syntax-attoparsec, syntax-pretty, syntax >= 0.2, syntax-attoparsec >= 0.2, syntax-pretty >= 0.2,
attoparsec, pretty, text attoparsec, pretty, text, scientific >= 0.3
default-language: Haskell2010 default-language: Haskell2010