infix prefix functions

diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs
index 6e9e373..91541f8 100644 (file)
--- a/datatype/Language/Quote.hs
+++ b/datatype/Language/Quote.hs
@@ -2,14 +2,14 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ParallelListComp #-}
-module Language.Quote (cp) where
+module Language.Quote (dsl) where
 
 import Data.Char
 import Data.Functor.Identity
---
+
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
---
+
 import Text.Parsec
 import Text.Parsec.String
 import Text.Parsec.Expr as E
@@ -18,8 +18,8 @@ import Text.Parsec.Language (haskell)
 --
 import Language.GenDSL
 
-cp :: QuasiQuoter
-cp = QuasiQuoter
+dsl :: QuasiQuoter
+dsl = QuasiQuoter
     { quoteExp = \s->location >>= parseExpr s
     , quotePat = undefined
     , quoteType = undefined
@@ -71,27 +71,29 @@ pat
 
 expr :: Parser Exp
 expr = buildExpressionParser
-    [ [bin "^." AssocRight]
-    , [bin "*." AssocLeft, bin "/." AssocLeft]
-    , [bin "+." AssocLeft, bin "-." AssocLeft]
-    , [bin o AssocNone | o <- ["==.", "/=.", "<.", ">.", "<=.", ">=."]]
-    , [bin "&." AssocRight]
-    , [bin "|." AssocRight]
+    [ [bin "^" AssocRight]
+    , [bin "*" AssocLeft, bin "/" AssocLeft]
+    , [bin "+" AssocLeft, bin "-" AssocLeft]
+    , [bin o AssocNone | o <- ["==", "/=", "<", ">", "<=", ">="]]
+    , [bin "&&" AssocRight]
+    , [bin "||" AssocRight]
+    , [E.Infix (fmap ifx $ P.lexeme haskell $ char '`' *> identifier <* char '`') AssocRight]
     ] basic
   where
     bin :: String -> Assoc -> Operator String () Identity Exp
-    bin str = E.Infix $ ifx str <$ sat operator (str==)
+    bin str = E.Infix $ ifx (str++".") <$ sat operator (str==)
         (("Expected operator " ++ str ++ " but got ")++)
 
     basic :: Parser Exp
     basic
         =   try (AppE . VarE <$> var <*> (TupE <$> parens (commaSep expr)))
         <|> VarE <$> var
-        <|> AppE (VarE (mkName "lit")) . LitE <$> lit
+        <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 ((,) <$> pat <* reservedOp "->" <*> expr)
+        <|> (\i t e->VarE (mkName "if'") `AppE` i `AppE` t `AppE` e) <$ reserved "if" <*> expr <* reserved "then" <*> expr <* reserved "else" <*> expr
         <|> parens expr
-        <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 match
-
-    match = (,) <$> pat <* reservedOp "->" <*> expr
+        <|> mkLit . LitE <$> lit
+        <|> mkLit . ConE . mkName <$> sat identifier ("True"==) ("Expected True but got: "++)
+        <|> mkLit . ConE . mkName <$> sat identifier ("False"==) ("Expected False but got: "++)
 
 sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a
 sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a))
@@ -101,6 +103,9 @@ lit
     =   CharL <$> P.charLiteral haskell
     <|> IntegerL <$> P.natural haskell
 
+mkLit :: Exp -> Exp
+mkLit = AppE $ VarE $ mkName "lit"
+
 con,var :: Parser Name
 con = mkName <$> sat identifier (isUpper . head) ("Not a data constructor: "++)
 var = mkName <$> sat identifier (isLower . head) ("Not a variable identifier: "++)

diff --git a/datatype/Main.hs b/datatype/Main.hs
index c68cb85..35d5ae6 100644 (file)
--- a/datatype/Main.hs
+++ b/datatype/Main.hs
@@ -93,17 +93,17 @@ f4
 
 f5 :: (List' v, Expression v, Function (v (List Int)) v) => Main (v Int)
 f5
-    = fun ( \sumf->(\l->[cp|case l of
+    = fun ( \sumf->(\l->[dsl|case l of
                 Nil -> 0
-                Cons e rest -> e +. sumf(rest)
+                Cons e rest -> e + sumf(rest)
             |])
 --    :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
-    :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
+    :- Main {unmain=[dsl|sumf (1 `cons` (2 `cons` (3 `cons` nil)))|]}
     )
 
 f6 :: (TupleR' v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int)
 f6
-    = fun ( \firstfun->(\l->[cp|case l of
+    = fun ( \firstfun->(\l->[dsl|case l of
                 TupleR {first=f} -> f
             |])
 --    :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
@@ -112,9 +112,9 @@ f6
 
 f7 :: (Expression v, Function (v Int) v) => Main (v Int)
 f7
-    = fun ( \ffac->(\l->[cp|case l of
+    = fun ( \ffac->(\l->[dsl|case l of
                 0 -> 1
-                n -> n *. ffac (n -. 1)
+                n -> if True then 1 else n * ffac (n - 1)
             |])
     :- Main {unmain=ffac (lit 10)}
     )
@@ -122,10 +122,10 @@ f7
 f7' :: (DSL v, List' v, Function (v (List Int)) v) => Main (v Int)
 f7'
     =    fun ( \fromto->(
-            \(from, to)->if' (from >. to) nil (from `cons` fromto (from +. lit 1, to))
+            \(from, to)->[dsl|if from > to then nil else from `cons` fromto (from + 1, to)|]
     ) :- fun ( \mullist->(
-            \l->[cp|case l of
-                Cons e rest -> e *. mullist(rest)
+            \l->[dsl|case l of
+                Cons e rest -> e * mullist(rest)
                 Nil -> 1
             |]
     ) :- fun ( \fac->(

diff --git a/datatype/clean.bash b/datatype/clean.bash
old mode 100644 (file)
new mode 100755 (executable)