...
 
Commits (6)
......@@ -70,6 +70,7 @@ library
Language.Grammars.AspectAG.TH,
Language.Grammars.AspectAG.HList,
Language.Grammars.AspectAG.TPrelude,
Language.Grammars.AspectAG.Label
Language.Grammars.AspectAG.GenRecord,
Language.Grammars.AspectAG.RecordInstances,
Language.Grammars.AspectAG.Require,
......
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-|
Module : Language.Grammars.AspectAG.GenRecord
Description : Record library, this will be eventually forked out
from AAG codebase and used as a standalone library, depending on it
Copyright : (c) Juan García Garland, Marcos Viera, 2019
License : GPL
Maintainer : jpgarcia@fing.edu.uy
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Language.Grammars.AspectAG.GenRecordTest where
import Data.Kind
import Data.Proxy
import Language.Grammars.AspectAG.GenRecord
import Language.Grammars.AspectAG.Label
import GHC.TypeLits
emp = EmptyRec :: Record '[]
label1 = Label @ "l1"
label2 = Label @ "l2"
label3 = Label @ "l3"
label4 = Label @ "l4"
label5 = Label @ "l5"
-- let us define simple records:
data Reco
type instance WrapField Reco v = v
type instance ShowRec Reco = "Record"
type instance ShowField Reco = "field named:"
type Record (r :: [(Symbol, Type)]) = Rec Reco r
tagField :: Label l -> v -> TagField Reco l v
tagField l v = TagField Label Label v
reco = -- "handmade" record, note labels in order
ConsRec (tagField label1 True)
$ ConsRec (tagField label2 "lolo")
$ ConsRec (tagField label4 (3::Int))
EmptyRec
-- lookup tests
true = reco # label1
-- boom = reco # label3 -- should have a nice error message
-- boom2 = reco # label5 -- should have a nice error message
anInt = reco # label4
-- update tests
t1 = update label2 'a' reco
t2 = update label4 'a' reco
--t3 = update label5 True reco
--t4 = update label3 True reco
-- extend
-- e1 = tagField label1 () .*. reco
e2 = tagField label3 () .*. reco
-- e3 = tagField label4 () .*. reco
instance Show (Record '[]) where
show _ = "{}"
instance (Show (Record r), Show v, KnownSymbol l)
=> Show (Record ( '(l, v) ': r )) where
show (ConsRec (TagField _ l v) r) =
let ('{':shr) = show r
in '{' : symbolVal l ++ " ↦ " ++ show v ++ ", " ++ shr
......@@ -27,6 +27,7 @@ Implementation of strongly typed heterogeneous lists.
module Language.Grammars.AspectAG.HList where
import Language.Grammars.AspectAG.TPrelude
import Language.Grammars.AspectAG.Label
import Data.Proxy
import Data.Type.Equality
import Data.Kind
......
{-|
Module : Language.Grammars.AspectAG.Label
Description : Labels (polykinded, phantom)
Copyright : (c) Juan García Garland, Marcos Viera 2020
License : GPL-3
Maintainer : jpgarcia@fing.edu.uy
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
module Language.Grammars.AspectAG.Label where
import Data.Proxy
data Label l = Label
sndLabel :: Label '(a,b) -> Label b
sndLabel _ = undefined
fstLabel :: Label '(a,b) -> Label a
fstLabel _ = undefined
labelFromType :: a -> Label a
labelFromType _ = Label
proxyToLabel :: Proxy a -> Label a
proxyToLabel _ = Label
......@@ -26,7 +26,7 @@ module Language.Grammars.AspectAG.RecordInstances where
import Language.Grammars.AspectAG.Require
import Language.Grammars.AspectAG.GenRecord
import Language.Grammars.AspectAG.TPrelude
import Language.Grammars.AspectAG.Label
import GHC.TypeLits
import Data.Kind
import Data.Proxy
......@@ -37,7 +37,14 @@ data Child = Chi Symbol Prod (Either NT T) --deriving Eq
data NT = NT Symbol --deriving Eq
data T = T Type -- deriving Eq
type instance Cmp ('Att a _) ('Att b _) =
CmpSymbol a b
type instance Cmp ('Prd a _) ('Prd b _) =
CmpSymbol a b
type instance Cmp ('Chi a _ _) ('Chi b _ _) =
CmpSymbol a b
type instance ShowT ('Att l t) = Text "Attribute " :<>: Text l
......@@ -72,11 +79,10 @@ type instance ShowField Reco = "field named "
-- | ** Pattern Synonyms
pattern EmptyR :: Rec Reco '[]
pattern EmptyR = EmptyRec :: Rec Reco '[]
pattern ConsR :: (LabelSet ( '(l,v ) ': xs))
=> Tagged l v -> Rec Reco xs -> Rec Reco ( '(l,v ) ': xs)
pattern ConsR lv r = ConsRec lv r
-- pattern EmptyR :: Rec Reco '[]
-- pattern EmptyR = EmptyRec :: Rec Reco '[]
-- pattern ConsR :: Tagged l v -> Rec Reco xs -> Rec Reco ( '(l,v ) ': xs)
-- pattern ConsR lv r = lv .*. r
type Tagged = TagField Reco
......@@ -93,7 +99,7 @@ l .=. v = Tagged v
-- | For the empty Record
emptyRecord :: Record '[]
emptyRecord = EmptyR
emptyRecord = EmptyRec
unTagged :: Tagged l v -> v
unTagged (TagField _ _ v) = v
......@@ -112,11 +118,11 @@ labelTChAtt _ = Label
instance Show (Record '[]) where
show _ = "{}"
instance (Show v, Show (Record xs), (LabelSet ('(l, v) : xs))) =>
instance (Show v, Show (Record xs)) =>
Show (Record ( '(l,v) ': xs ) ) where
show (ConsR lv xs) = let tail = show xs
in "{" ++ show (unTagged lv)
++ "," ++ drop 1 tail
show (ConsRec lv xs) = let tail = show xs
in "{" ++ show (unTagged lv)
++ "," ++ drop 1 tail
......@@ -137,11 +143,11 @@ type instance ShowRec AttReco = "Attribution"
type instance ShowField AttReco = "attribute named "
-- | Pattern Synonyms
pattern EmptyAtt :: Attribution '[]
pattern EmptyAtt = EmptyRec
pattern ConsAtt :: LabelSet ( '(att, val) ': atts) =>
Attribute att val -> Attribution atts -> Attribution ( '(att,val) ': atts)
pattern ConsAtt att atts = ConsRec att atts
-- pattern EmptyAtt :: Attribution '[]
-- pattern EmptyAtt = EmptyRec
-- pattern ConsAtt :: LabelSet ( '(att, val) ': atts) =>
-- Attribute att val -> Attribution atts -> Attribution ( '(att,val) ': atts)
-- pattern ConsAtt att atts = ConsRec att atts
-- | Attribute
......@@ -159,10 +165,9 @@ Label =. v = Attribute v
-- | Extending
infixr 2 *.
(*.) :: LabelSet ('(att, val) : atts) =>
Attribute att val -> Attribution atts
-> Attribution ('(att, val) : atts)
(*.) = ConsRec
-- (*.) :: Attribute att val -> Attribution atts
-- -> Attribution (ReqR (OpExtend AttReco att val atts) ctx)
(l :: Attribute att val) *. (r :: Attribution atts) = l .*. r
-- | Empty
emptyAtt :: Attribution '[]
......@@ -209,12 +214,12 @@ type instance ShowField (ChiReco a) = "child labelled "
-- |since now we implement ChAttsRec as a generic record, this allows us to
-- recover pattern matching
pattern EmptyCh :: ChAttsRec prd '[]
pattern EmptyCh = EmptyRec
pattern ConsCh :: (LabelSet ( '( 'Chi ch prd nt, v) ': xs)) =>
TaggedChAttr prd ( 'Chi ch prd nt) v -> ChAttsRec prd xs
-> ChAttsRec prd ( '( 'Chi ch prd nt,v) ': xs)
pattern ConsCh h t = ConsRec h t
-- pattern EmptyCh :: ChAttsRec prd '[]
-- pattern EmptyCh = EmptyRec
-- pattern ConsCh :: (LabelSet ( '( 'Chi ch prd nt, v) ': xs)) =>
-- TaggedChAttr prd ( 'Chi ch prd nt) v -> ChAttsRec prd xs
-- -> ChAttsRec prd ( '( 'Chi ch prd nt,v) ': xs)
-- pattern ConsCh h t = ConsRec h t
-- | Attributions tagged by a child
type TaggedChAttr prd = TagField (ChiReco prd)
......@@ -232,10 +237,8 @@ infixr 4 .=
-- | Pretty constructors
infixr 2 .*
(.*) :: LabelSet ('(ch, attrib) ': attribs) =>
TaggedChAttr prd ch attrib -> ChAttsRec prd attribs
-> ChAttsRec prd ('(ch, attrib) ': attribs)
(.*) = ConsRec
(tch :: TaggedChAttr prd ch attrib) .* (chs :: ChAttsRec prd attribs) = tch .*. chs
-- TODO: error instances if different prds are used?
-- | empty
emptyCh :: ChAttsRec prd '[]
......
......@@ -25,9 +25,13 @@ module Language.Grammars.AspectAG.Require where
import Data.Kind
import Data.Proxy
import GHC.TypeLits
import Language.Grammars.AspectAG.TPrelude
import Data.Type.Bool
import Data.Type.Equality
type family Equal (a:: k)(b :: k') :: Bool where
Equal a a = True
Equal a b = False
class Require (op :: Type)
(ctx :: [ErrorMessage]) where
type ReqR op :: Type
......@@ -48,6 +52,8 @@ type family ShowEM (m :: ErrorMessage) :: ErrorMessage
type family ShowT (t :: k) :: ErrorMessage
type instance ShowT (t :: Type) = ShowType t
type instance ShowT (t :: Symbol) = Text t
{-
Abro esta familia para poder definirla de manera extensible, porque no sabemos
en GenReord como se muestran los tipos para instancias concretas. El problema es
......
......@@ -28,25 +28,16 @@ Portability : POSIX
module Language.Grammars.AspectAG.TPrelude where
import Data.Kind
import Data.Type.Equality
import Data.Type.Bool
import GHC.TypeLits
import Data.Proxy
data Label l = Label
sndLabel :: Label '(a,b) -> Label b
sndLabel _ = undefined
getProxy :: a -> Proxy a ; getProxy _ = Proxy
getLabel :: a -> Label a ; getLabel _ = Label
proxyFrom :: t a -> Proxy a
proxyFrom _ = Proxy
-- | If construction, purely computed at type level
type family If (cond:: Bool) (thn :: k) (els :: k) :: k where
If 'True thn els = thn
If 'False thn els = els
-- type family If (cond:: Bool) (thn :: k) (els :: k) :: k where
-- If 'True thn els = thn
-- If 'False thn els = els
-- | Or, purely computed at type level
type family Or (l :: Bool)(r :: Bool) :: Bool where
......@@ -54,15 +45,15 @@ type family Or (l :: Bool)(r :: Bool) :: Bool where
Or True b = 'True
-- | And, purely computed at type level
type family And (l :: Bool)(r :: Bool) :: Bool where
And False b = False
And True b = b
-- -- | And, purely computed at type level
-- type family And (l :: Bool)(r :: Bool) :: Bool where
-- And False b = False
-- And True b = b
-- | Not, purely computed at type level
type family Not (l :: Bool) :: Bool where
Not False = True
Not True = False
-- -- | Not, purely computed at type level
-- type family Not (l :: Bool) :: Bool where
-- Not False = True
-- Not True = False
-- | LabelSet is a predicate over lists of pairs.
......@@ -129,7 +120,7 @@ type family HasLabel (l :: k) (r :: [(k, k')]) :: Bool where
HasLabel l ( '(l', v) ': r) = Or (l == l') (HasLabel l r)
type family Equal (a:: k)(b :: k') :: Bool where
-- Equal (f a) (g b) = And (Equal f g) (Equal a b)
Equal a a = True
Equal a b = False
-- type family Equal (a:: k)(b :: k') :: Bool where
-- -- Equal (f a) (g b) = And (Equal f g) (Equal a b)
-- Equal a a = True
-- Equal a b = False
......@@ -239,7 +239,6 @@ synmod att prd f =
\inp (Fam ic sp) ->
Fam ic $ update att Proxy (f inp) sp
synmodM att prd = synmod att prd . runReader
inhdef ::
......