aterm-utils 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+191/−10 lines, 3 filesdep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

API changes (from Hackage documentation)

Files

• aterm-utils.cabal +4/−2
• src/ATerm/Generics.hs +181/−0
• src/ATerm/Matching.hs +6/−8

@@ -1,5 +1,5 @@ name:                aterm-utils-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Utility functions for working with aterms as generated by Minitermite -- description:          license:             BSD3@@ -29,12 +29,14 @@  library -  exposed-modules:   ATerm.Utilities+  exposed-modules:   ATerm.Generics                    , ATerm.Matching                    , ATerm.Pretty+                   , ATerm.Utilities    Build-depends:       base < 5                      , aterm+                     , mtl                      , transformers                      , wl-pprint 

@@ -0,0 +1,181 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PatternGuards #-}+module ATerm.Generics where++import ATerm.Unshared hiding (fromATerm)+import GHC.Generics+import Control.Applicative+import Control.Monad.State++------------------------------------------------------------------------+-- Generic data type serialization+------------------------------------------------------------------------++class GToATerm f where+  gToATerm :: f a -> ATerm++instance GToATerm a => GToATerm (D1 c a) where+  gToATerm (M1 x) = gToATerm x++instance (GToATerm f, GToATerm g) => GToATerm (f :+: g) where+  gToATerm (L1 x) = gToATerm x+  gToATerm (R1 x) = gToATerm x++instance (Constructor c, GToATerms a) => GToATerm (C1 c a) where+  gToATerm m1 = AAppl (conName m1) (gToATerms (unM1 m1) []) []+++------------------------------------------------------------------------+-- Generic constructor serialization+------------------------------------------------------------------------++class                                  GToATerms f         where gToATerms          :: f a -> [ATerm] -> [ATerm]+instance GToATerms f                => GToATerms (S1 i f)  where gToATerms (M1 x)    = gToATerms x+instance (GToATerms f, GToATerms g) => GToATerms (f :*: g) where gToATerms (f :*: g) = gToATerms f . gToATerms g+instance ToATerm a                  => GToATerms (Rec0 a)  where gToATerms (K1 x)    = (toATerm x:)+instance                               GToATerms U1        where gToATerms U1        = id++------------------------------------------------------------------------+-- Serialization+------------------------------------------------------------------------++class ToATerm a where+  toATerm :: a -> ATerm+  default toATerm :: (Generic a, GToATerm (Rep a)) => a -> ATerm+  toATerm x = gToATerm (from x)++  toATermList :: [a] -> ATerm+  default toATermList :: Generic a => [a] -> ATerm+  toATermList = listToATerm++-- Automatically derived instances+instance                           ToATerm Bool+instance                           ToATerm Float+instance                           ToATerm Double+instance                           ToATerm ()+instance ToATerm a              => ToATerm (Maybe a)+instance (ToATerm a, ToATerm b) => ToATerm (a,b)+instance (ToATerm a, ToATerm b) => ToATerm (Either a b)++instance                           ToATerm Char    where toATerm     = showToATerm+                                                         toATermList = stringToATerm+instance                           ToATerm Int     where toATerm     = integralToATerm+instance                           ToATerm Integer where toATerm     = integralToATerm+                                                         toATermList = listToATerm+instance ToATerm a              => ToATerm [a]     where toATerm     = toATermList++-- Base type implementations+integralToATerm :: Integral a => a -> ATerm+integralToATerm x = AInt (toInteger x) []++showToATerm :: Show a => a -> ATerm+showToATerm x = AAppl (show x) [] []++listToATerm :: ToATerm a => [a] -> ATerm+listToATerm xs = AList (map toATerm xs) []++stringToATerm :: String -> ATerm+stringToATerm s = AAppl (show s) [] []++------------------------------------------------------------------------+-- Deserialization+------------------------------------------------------------------------++class FromATerm a where+  fromATerm :: ATerm -> Maybe a++  default fromATerm :: (Generic a, GFromATerm (Rep a)) => ATerm -> Maybe a+  fromATerm a = to <$> gFromATerm a++  fromATermList :: ATerm -> Maybe [a]++  default fromATermList :: ATerm -> Maybe [a]+  fromATermList = atermToList++-- Automatically derived instances+instance FromATerm                                  ()+instance FromATerm                                  Bool+instance FromATerm                                  Float+instance FromATerm                                  Double+instance (FromATerm a, FromATerm b)              => FromATerm (a,b)+instance (FromATerm a, FromATerm b, FromATerm c) => FromATerm (a, b, c)+instance (FromATerm a, FromATerm b)              => FromATerm (Either a b)+instance FromATerm a                             => FromATerm (Maybe a)++instance                FromATerm Int     where fromATerm     = atermToIntegral+instance                FromATerm Integer where fromATerm     = atermToIntegral+instance                FromATerm Char    where fromATerm     = atermToRead+                                                fromATermList = atermToString+instance FromATerm a => FromATerm [a]     where fromATerm     = fromATermList++-- Base type implementations+atermToIntegral :: Integral a => ATerm -> Maybe a+atermToIntegral (AInt x _) = Just (fromIntegral x)+atermToIntegral _          = Nothing++atermToRead :: Read a => ATerm -> Maybe a+atermToRead (AAppl x [] _) | [(z,"")] <- reads x = Just z+atermToRead _                                    = Nothing++atermToString :: ATerm -> Maybe String+atermToString (AAppl ('"':x) [] _) | null x        = Nothing+                                   | last x == '"' = Just (init x)+atermToString _                                    = Nothing++atermToList :: FromATerm a => ATerm -> Maybe [a]+atermToList (AList as _) = mapM fromATerm as+atermToList _            = Nothing+++------------------------------------------------------------------------+-- Generic data type deserialization+------------------------------------------------------------------------++class GFromATerm f where+  gFromATerm :: ATerm -> Maybe (f a)++instance GFromATerm a => GFromATerm (D1 c a) where+  gFromATerm a = M1 <$> gFromATerm a++instance (GFromATerm f, GFromATerm g) => GFromATerm (f :+: g) where+  gFromATerm a = L1 <$> gFromATerm a -- try to deserialize as the left side+             <|> R1 <$> gFromATerm a -- fail over to deserializing on the right++instance (Constructor c, GFromATerms a) => GFromATerm (C1 c a) where+  gFromATerm (AAppl str xs _) =+    -- Lambda used to get a monomorphic binding+    -- conName does not evaluate its argument+    (\result@(~(Just x)) -> if conName x == str then result else Nothing)+    (M1 <$> gFromATerms' xs)++  gFromATerm _ = Nothing++------------------------------------------------------------------------+-- Generic constructor deserialization+------------------------------------------------------------------------++-- | Convert all the 'ATerm' elements into the requested structure+gFromATerms' :: GFromATerms f => [ATerm] -> Maybe (f a)+gFromATerms' = evalStateT $ do+  res <- gFromATerms+  []  <- get -- check that all aterms are consumed+  return res++-- | Convert the next 'ATerm' to the next needed field type+next :: FromATerm a => StateT [ATerm] Maybe a+next = do+  x:xs <- get -- pattern failure happens in Maybe+  put xs+  lift (fromATerm x)++class                                      GFromATerms f         where gFromATerms :: StateT [ATerm] Maybe (f a)+instance GFromATerms f                  => GFromATerms (S1 i f)  where gFromATerms = M1    <$> gFromATerms+instance (GFromATerms f, GFromATerms g) => GFromATerms (f :*: g) where gFromATerms = (:*:) <$> gFromATerms <*> gFromATerms+instance FromATerm a                    => GFromATerms (Rec0 a)  where gFromATerms = K1    <$> next+instance                                   GFromATerms U1        where gFromATerms = pure U1++-- example:   fromATerm (toATerm ('a', True)) :: Maybe (Char, Bool)

@@ -59,7 +59,7 @@ exactlyL :: MonadPlus m => [ATermTable -> m a] -> ATermTable -> m [a] exactlyL ms t = case getATerm t of   ShAList ls _ -> do-    _ <- guard (length ms == length ls)+    guard (length ms == length ls)     sequence (zipWith (\m i -> m (getATermByIndex1 i t)) ms ls)   _ -> mzero @@ -67,18 +67,16 @@ exactlyA :: MonadPlus m => String -> [ATermTable -> m a] -> ATermTable -> m [a] exactlyA s ms t = case getATerm t of   ShAAppl s' ls _ -> do-    _ <- exactly s s'-    _ <- guard (length ms == length ls)+    exactly s s'+    guard (length ms == length ls)     sequence (zipWith (\m i -> U.app m t i) ms ls)   _ -> mzero  -- | Looks for an Appl with name 's' and any children exactlyNamed :: MonadPlus m => String -> ATermTable -> m () exactlyNamed s t = case getATerm t of-  ShAAppl s' _ _ -> do-    _ <- exactly s s'-    return ()-  _ -> mzero+  ShAAppl s' _ _ -> exactly s s'+  _              -> mzero  --------------------------------------------------------------------- -- ** Partial matchers, ie., they just specify part of the structure@@ -114,7 +112,7 @@ containsA :: String -> [ATermTable -> a] -> ATermTable -> [a] containsA s ams t = case getATerm t of   ShAAppl s' ls _ -> do-    _ <- exactly s s'+    exactly s s'     containsChildren ams ls t   _               -> mzero