From 73ba5f8adcbbaa3092495b5910772979f034d3f0 Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+lol@autogeree.net>
Date: Sat, 8 Oct 2016 02:01:49 +0200
Subject: [PATCH] init
---
Language/LOL/Symantic/AST/Test.hs | 11 +++---
Language/LOL/Symantic/Expr.hs | 2 ++
Language/LOL/Symantic/Expr/Eq.hs | 19 ++++++++++
Language/LOL/Symantic/Expr/Eq/Test.hs | 27 +++++++++++++++
Language/LOL/Symantic/Expr/Test.hs | 2 ++
Language/LOL/Symantic/Repr/Host.hs | 14 ++++----
Language/LOL/Symantic/Repr/Text.hs | 46 +++++++++++++++----------
Language/LOL/Symantic/Repr/Text/Test.hs | 6 ++++
lol-symantic.cabal | 4 ++-
9 files changed, 100 insertions(+), 31 deletions(-)
create mode 100644 Language/LOL/Symantic/Expr/Eq.hs
create mode 100644 Language/LOL/Symantic/Expr/Eq/Test.hs
diff --git a/Language/LOL/Symantic/AST/Test.hs b/Language/LOL/Symantic/AST/Test.hs
index b9164fd..2b32695 100644
--- a/Language/LOL/Symantic/AST/Test.hs
+++ b/Language/LOL/Symantic/AST/Test.hs
@@ -39,19 +39,20 @@ instance Show AST where
case ast of
AST _ [] -> showString n
AST "->" [a] ->
- showParen (p >= 1) $
+ showParen (p >= prec_arrow) $
showString ("("++n++") ") .
- showsPrec 2 a
+ showsPrec prec_arrow a
AST "->" [a, b] ->
- showParen (p >= 1) $
- showsPrec 2 a .
+ showParen (p >= prec_arrow) $
+ showsPrec prec_arrow a .
showString (" "++n++" ") .
- showsPrec 2 b
+ showsPrec prec_arrow b
_ ->
showString n .
showString "(" .
showString (List.intercalate ", " $ show <$> args) .
showString ")"
+ where prec_arrow = 1
instance -- Type_from AST Type_Var
( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
diff --git a/Language/LOL/Symantic/Expr.hs b/Language/LOL/Symantic/Expr.hs
index e74671b..cc28398 100644
--- a/Language/LOL/Symantic/Expr.hs
+++ b/Language/LOL/Symantic/Expr.hs
@@ -6,6 +6,7 @@ module Language.LOL.Symantic.Expr
, module Language.LOL.Symantic.Expr.Bool
, module Language.LOL.Symantic.Expr.Maybe
, module Language.LOL.Symantic.Expr.If
+ , module Language.LOL.Symantic.Expr.Eq
) where
import Language.LOL.Symantic.Expr.Common
@@ -14,3 +15,4 @@ import Language.LOL.Symantic.Expr.Int
import Language.LOL.Symantic.Expr.Bool
import Language.LOL.Symantic.Expr.Maybe
import Language.LOL.Symantic.Expr.If
+import Language.LOL.Symantic.Expr.Eq
diff --git a/Language/LOL/Symantic/Expr/Eq.hs b/Language/LOL/Symantic/Expr/Eq.hs
new file mode 100644
index 0000000..7e8ef03
--- /dev/null
+++ b/Language/LOL/Symantic/Expr/Eq.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+-- | Expression for 'Eq'.
+module Language.LOL.Symantic.Expr.Eq where
+
+import Language.LOL.Symantic.Repr.Dup
+import Language.LOL.Symantic.Trans.Common
+
+-- * Class 'Sym_Eq'
+
+class Sym_Eq repr where
+ eq :: Eq a => repr a -> repr a -> repr Bool
+ default eq :: (Trans t repr, Eq a) => t repr a -> t repr a -> t repr Bool
+ eq = trans_map2 eq
+
+instance (Sym_Eq r1, Sym_Eq r2) => Sym_Eq (Dup r1 r2) where
+ eq (x1 `Dup` x2) (y1 `Dup` y2) = eq x1 y1 `Dup` eq x2 y2
diff --git a/Language/LOL/Symantic/Expr/Eq/Test.hs b/Language/LOL/Symantic/Expr/Eq/Test.hs
new file mode 100644
index 0000000..c3e1fac
--- /dev/null
+++ b/Language/LOL/Symantic/Expr/Eq/Test.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+module Expr.Eq.Test where
+
+import Test.Tasty
+
+import Prelude hiding (and, not, or)
+
+import Language.LOL.Symantic.Expr.Bool
+import Language.LOL.Symantic.Expr.If
+import Language.LOL.Symantic.Expr.Eq
+
+-- * Expressions
+t = bool True
+f = bool False
+e1 = if_ ((t `and` t) `eq` (t `or` f)) t f
+e2 = if_ (((t `and` t) `or` f) `eq` (t `and` (t `or` f))) t f
+e3 = if_ (not (t `eq` f) `eq` (t `eq` t)) t f
+
+
+tests :: TestTree
+tests =
+ testGroup "Eq"
+ [
+ ]
diff --git a/Language/LOL/Symantic/Expr/Test.hs b/Language/LOL/Symantic/Expr/Test.hs
index d78740a..b7256ec 100644
--- a/Language/LOL/Symantic/Expr/Test.hs
+++ b/Language/LOL/Symantic/Expr/Test.hs
@@ -7,6 +7,7 @@ import qualified Expr.Bool.Test as Bool
import qualified Expr.Int.Test as Int
import qualified Expr.Maybe.Test as Maybe
import qualified Expr.If.Test as If
+import qualified Expr.Eq.Test as Eq
tests :: TestTree
tests =
@@ -16,4 +17,5 @@ tests =
, Int.tests
, Maybe.tests
, If.tests
+ , Eq.tests
]
diff --git a/Language/LOL/Symantic/Repr/Host.hs b/Language/LOL/Symantic/Repr/Host.hs
index 4e7f502..007086a 100644
--- a/Language/LOL/Symantic/Repr/Host.hs
+++ b/Language/LOL/Symantic/Repr/Host.hs
@@ -5,7 +5,7 @@
-- | Interpreter to compute a host-term.
module Language.LOL.Symantic.Repr.Host where
-import qualified Control.Monad as Monad (when)
+import Control.Monad as Monad
import Control.Monad.IO.Class (MonadIO(..))
import Data.IORef
import qualified Data.Bool as Bool
@@ -38,13 +38,13 @@ instance MonadIO lam => Sym_Lambda lam (Repr_Host lam) where
lazy f = return $ ((>>= unRepr_Host . f . Repr_Host) . expr_lambda_lazy_share)
instance Monad lam => Sym_Bool (Repr_Host lam) where
bool = return
- not = liftMJoin $ return . Bool.not
- and = liftM2Join $ \x y -> return $ x && y
- or = liftM2Join $ \x y -> return $ x || y
+ not = fmap Bool.not
+ and = liftM2 (&&)
+ or = liftM2 (||)
instance Monad lam => Sym_Int (Repr_Host lam) where
int = return
- neg = liftMJoin $ return . negate
- add = liftM2Join $ \x y -> return $ x + y
+ neg = fmap negate
+ add = liftM2 (+)
instance MonadIO lam => Sym_Maybe lam (Repr_Host lam) where
maybe n j m = do
mm <- m
@@ -60,6 +60,8 @@ instance Monad lam => Sym_When (Repr_Host lam) where
when m ok = do
m' <- m
Monad.when m' ok
+instance Monad lam => Sym_Eq (Repr_Host lam) where
+ eq = liftM2 (==)
--instance Monad lam => Sym_Eq (Repr_Host lam) where
-- eq = liftM2Join $ \x y -> return $ x == y
diff --git a/Language/LOL/Symantic/Repr/Text.hs b/Language/LOL/Symantic/Repr/Text.hs
index 068c13f..3557576 100644
--- a/Language/LOL/Symantic/Repr/Text.hs
+++ b/Language/LOL/Symantic/Repr/Text.hs
@@ -77,7 +77,7 @@ instance Sym_Bool (Repr_Text lam) where
not (Repr_Text x) =
Repr_Text $ \p v ->
let p' = precedence_Not in
- paren p p' $ "!" <> x (precedence_succ p') v
+ paren p p' $ "!" <> x p' v
and (Repr_Text x) (Repr_Text y) =
Repr_Text $ \p v ->
let p' = precedence_And in
@@ -97,7 +97,7 @@ instance Sym_Int (Repr_Text lam) where
neg (Repr_Text x) =
Repr_Text $ \p v ->
let p' = precedence_Neg in
- paren p p' $ "-" <> x (precedence_succ p') v
+ paren p p' $ "-" <> x p' v
add (Repr_Text x) (Repr_Text y) =
Repr_Text $ \p v ->
let p' = precedence_Add in
@@ -105,20 +105,20 @@ instance Sym_Int (Repr_Text lam) where
instance Sym_Maybe lam (Repr_Text lam) where
maybe (Repr_Text n) (Repr_Text j) (Repr_Text m) =
Repr_Text $ \p v ->
- let p' = precedence_Lambda in
+ let p' = precedence_App in
paren p p' $ "maybe"
- <> " " <> n (precedence_succ p') v
- <> " " <> j (precedence_succ p') v
- <> " " <> m (precedence_succ p') v
+ <> " " <> n p' v
+ <> " " <> j p' v
+ <> " " <> m p' v
instance Sym_Maybe_Cons (Repr_Text lam) where
nothing =
Repr_Text $ \_p _v ->
"nothing"
just (Repr_Text a) =
Repr_Text $ \p v ->
- let p' = precedence_Lambda in
+ let p' = precedence_App in
paren p p' $ "just "
- <> a (precedence_succ p') v
+ <> a (p') v
instance Sym_If (Repr_Text lam) where
if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
Repr_Text $ \p v ->
@@ -134,6 +134,12 @@ instance Sym_When (Repr_Text lam) where
paren p p' $
"when " <> cond p' v <>
" " <> ok p' v
+instance Sym_Eq (Repr_Text lam) where
+ eq (Repr_Text x) (Repr_Text y) =
+ Repr_Text $ \p v ->
+ let p' = precedence_Eq in
+ paren p p' $
+ x p' v <> " == " <> y p' v
-- ** Type 'Precedence'
@@ -153,23 +159,25 @@ precedence_Toplevel :: Precedence
precedence_Toplevel = Precedence 0
precedence_Lambda :: Precedence
precedence_Lambda = Precedence 1
-precedence_Let :: Precedence
-precedence_Let = Precedence 2
precedence_If :: Precedence
-precedence_If = Precedence 3
+precedence_If = Precedence 2
+precedence_Let :: Precedence
+precedence_Let = Precedence 3
+precedence_Eq :: Precedence
+precedence_Eq = Precedence 4
precedence_Or :: Precedence
-precedence_Or = Precedence 4
-precedence_Add :: Precedence
-precedence_Add = precedence_Or
+precedence_Or = Precedence 5
precedence_Xor :: Precedence
-precedence_Xor = Precedence 5
+precedence_Xor = Precedence 6
precedence_And :: Precedence
-precedence_And = Precedence 6
+precedence_And = Precedence 7
+precedence_Add :: Precedence
+precedence_Add = precedence_And
precedence_App :: Precedence
-precedence_App = Precedence 7
+precedence_App = Precedence 8
precedence_Not :: Precedence
-precedence_Not = Precedence 8
+precedence_Not = Precedence 9
precedence_Neg :: Precedence
precedence_Neg = precedence_Not
precedence_Atomic :: Precedence
-precedence_Atomic = Precedence 9
+precedence_Atomic = Precedence maxBound
diff --git a/Language/LOL/Symantic/Repr/Text/Test.hs b/Language/LOL/Symantic/Repr/Text/Test.hs
index 166f1a2..e294042 100644
--- a/Language/LOL/Symantic/Repr/Text/Test.hs
+++ b/Language/LOL/Symantic/Repr/Text/Test.hs
@@ -10,6 +10,7 @@ import Language.LOL.Symantic.Repr
import qualified Expr.Lambda.Test as Lambda.Test
import qualified Expr.Bool.Test as Bool.Test
import qualified Expr.Maybe.Test as Maybe.Test
+import qualified Expr.Eq.Test as Eq.Test
tests :: TestTree
tests = testGroup "String" $
@@ -40,6 +41,11 @@ tests = testGroup "String" $
, testGroup "Maybe"
[ Maybe.Test.e1 ==> "maybe True (\\x0 -> !x0) (just True)"
]
+ , testGroup "Eq"
+ [ Eq.Test.e1 ==> "if True & True == True | False then True else False"
+ , Eq.Test.e2 ==> "if True & True | False == True & (True | False) then True else False"
+ , Eq.Test.e3 ==> "if !(True == False) == (True == True) then True else False"
+ ]
{-, testGroup "If"
[ If.e1 ==> "if True then False else True"
, If.e2 ==> "if True & True then False else True"
diff --git a/lol-symantic.cabal b/lol-symantic.cabal
index 43a863f..432bacf 100644
--- a/lol-symantic.cabal
+++ b/lol-symantic.cabal
@@ -101,6 +101,7 @@ Library
Language.LOL.Symantic.Expr.Lambda
Language.LOL.Symantic.Expr.Maybe
Language.LOL.Symantic.Expr.If
+ Language.LOL.Symantic.Expr.Eq
Language.LOL.Symantic.Lib.Control.Monad
Language.LOL.Symantic.Lib.Data.Peano
Language.LOL.Symantic.Repr
@@ -138,14 +139,15 @@ Test-Suite lol-symantic-test
other-modules:
AST.Test
Expr.Bool.Test
+ Expr.Eq.Test
Expr.If.Test
Expr.Int.Test
Expr.Lambda.Test
Expr.Maybe.Test
Expr.Test
Repr.Host.Test
- Repr.Text.Test
Repr.Test
+ Repr.Text.Test
Trans.Bool.Const.Test
Trans.Bool.Test
Trans.Test
--
2.47.2