Browse Source

init - transformBi and universeBi

master
soupi 1 year ago
commit
fd6a298c31
13 changed files with 730 additions and 0 deletions
  1. +124
    -0
      .gitignore
  2. +31
    -0
      .gitlab-ci.yml
  3. +3
    -0
      ChangeLog.md
  4. +30
    -0
      LICENSE
  5. +1
    -0
      README.md
  6. +51
    -0
      generic-plate.cabal
  7. +22
    -0
      src/Data/Generics/Plated.hs
  8. +93
    -0
      src/Data/Generics/Plated/Transform.hs
  9. +87
    -0
      src/Data/Generics/Plated/Universe.hs
  10. +6
    -0
      stack.yaml
  11. +166
    -0
      test/Spec.hs
  12. +12
    -0
      test/Testset.hs
  13. +104
    -0
      test/Type.hs

+ 124
- 0
.gitignore View File

@@ -0,0 +1,124 @@
# Created by https://www.gitignore.io

### vim ###
[._]*.s[a-w][a-z]
[._]s[a-w][a-z]
*.un~
Session.vim
.netrwhist
*~


# Created by https://www.gitignore.io/api/emacs

### Emacs ###
# -*- mode: gitignore; -*-
*~
\#*\#
/.emacs.desktop
/.emacs.desktop.lock
*.elc
auto-save-list
tramp
.\#*

# Org-mode
.org-id-locations
*_archive

# flymake-mode
*_flymake.*

# eshell files
/eshell/history
/eshell/lastdir

# elpa packages
/elpa/

# reftex files
*.rel

# AUCTeX auto folder
/auto/

# cask packages
.cask/



### Haskell ###
dist
cabal-dev
*.o
*.hi
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.ps
*.prof
*.prof.*
*.aux
*.hp
.stack-work/
stack.yaml.lock


### Linux ###
*~

# KDE directory preferences
.directory


### OSX ###
.DS_Store
.AppleDouble
.LSOverride

# Icon must end with two \r
Icon


# Thumbnails
._*

# Files that might appear on external disk
.Spotlight-V100
.Trashes

# Directories potentially created on remote AFP share
.AppleDB
.AppleDesktop
Network Trash Folder
Temporary Items
.apdisk


### Windows ###
# Windows image file caches
Thumbs.db
ehthumbs.db

# Folder config file
Desktop.ini

# Recycle Bin used on file shares
$RECYCLE.BIN/

# Windows Installer files
*.cab
*.msi
*.msm
*.msp

# Windows shortcuts
*.lnk


~

+ 31
- 0
.gitlab-ci.yml View File

@@ -0,0 +1,31 @@
# Using https://vadosware.io/post/zero-to-continuous-integrated-testing-a-haskell-project-with-gitlab/


variables:
STACK_ROOT: "${CI_PROJECT_DIR}/.stack"

cache:
paths:
- .stack
- .stack-work
- target

before_script:
- apt-get update
- apt-get install make xz-utils
- wget -qO- https://get.haskellstack.org/ | sh

stages:
- build
- test

build:
stage: build
script:
- stack build --no-terminal

tests:
stage: test
script:
- stack test --no-terminal


+ 3
- 0
ChangeLog.md View File

@@ -0,0 +1,3 @@
# Changelog for generic-plate

## Unreleased changes

+ 30
- 0
LICENSE View File

@@ -0,0 +1,30 @@
Copyright Gil Mizrahi (c) 2020

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.

* Neither the name of Author name here nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ 1
- 0
README.md View File

@@ -0,0 +1 @@
# generic-plate

+ 51
- 0
generic-plate.cabal View File

@@ -0,0 +1,51 @@
cabal-version: 1.12

name: generic-plate
version: 0.0.0.0
description: Please see the README on GitLab at <https://gitlab.com/gilmi/generic-plate#readme>
homepage: https://gitlab.com/gilmi/generic-plate#readme
bug-reports: https://gitlab.com/gilmi/generic-plate/issues
author: Gil Mizrahi
maintainer: gilmi@posteo.net
copyright: 2020 Gil Mizrahi
license: BSD3
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
ChangeLog.md

source-repository head
type: git
location: https://gitlab.com/gilmi/generic-plate

library
exposed-modules:
Data.Generics.Plated
Data.Generics.Plated.Transform
Data.Generics.Plated.Universe
hs-source-dirs:
src
build-depends:
base >=4.7 && <5
, dlist

default-language: Haskell2010

test-suite generic-plate-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Type
Testset
hs-source-dirs:
test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, containers
, deepseq
, uniplate
, criterion
, generic-plate
default-language: Haskell2010

+ 22
- 0
src/Data/Generics/Plated.hs View File

@@ -0,0 +1,22 @@

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}

module Data.Generics.Plated
( module Data.Generics.Plated.Transform
, module Data.Generics.Plated.Universe
)
where

import GHC.Generics

import Data.Generics.Plated.Transform
import Data.Generics.Plated.Universe


+ 93
- 0
src/Data/Generics/Plated/Transform.hs View File

@@ -0,0 +1,93 @@


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MonoLocalBinds #-}

module Data.Generics.Plated.Transform where

import GHC.Generics

---------------
-- Transform --
---------------

-- GTransform --

class GTransform on struct where
gtransform :: (on -> on) -> struct x -> struct x

instance GTransform a U1 where
gtransform _ U1 = U1
{-# inline gtransform #-}

instance GTransform a V1 where
gtransform _ x = x
{-# inline gtransform #-}

instance {-# OVERLAPPING #-} TransformRec on on => GTransform on (Rec0 on) where
gtransform f (K1 a) = K1 (f $ transformRec f a)
{-# inline gtransform #-}

instance TransformRec on from => GTransform on (K1 _1 from) where
gtransform f (K1 from) = K1 (transformRec f from)
{-# inline gtransform #-}

instance (GTransform on x, GTransform on y) => GTransform on (x :+: y) where
gtransform f = \case
L1 x -> L1 $ gtransform f x
R1 y -> R1 $ gtransform f y
{-# inline gtransform #-}

instance (GTransform on x, GTransform on y) => GTransform on (x :*: y) where
gtransform f (x :*: y) = gtransform f x :*: gtransform f y
{-# inline gtransform #-}

instance GTransform on struct => GTransform on (M1 _x _y struct) where
gtransform f (M1 a) = M1 $ gtransform f a
{-# inline gtransform #-}

-- TransformRec --

class TransformRec on from where
transformRec :: (on -> on) -> from -> from
default transformRec :: Generic from => GTransform on (Rep from) => (on -> on) -> from -> from
transformRec f x = to (gtransform f (from x))
{-# inline transformRec #-}

instance {-# OVERLAPPING #-} (Generic from, GTransform on (Rep from)) => TransformRec on from where
transformRec f x = to (gtransform f (from x))
{-# inline transformRec #-}

instance {-# OVERLAPPING #-} (Generic on, GTransform on (Rep on)) => TransformRec on on

instance {-# overlapping #-} TransformRec on Int where
transformRec f x = x
{-# inline transformRec #-}

instance {-# overlapping #-} TransformRec on Char where
transformRec f x = x
{-# inline transformRec #-}

-- TransformBi --

class TransformBi on from where
transformBi :: (on -> on) -> from -> from
default transformBi :: Generic from => GTransform on (Rep from) => (on -> on) -> from -> from
transformBi f x = to (gtransform f (from x))
{-# inline transformBi #-}

instance {-# overlapping #-} (Generic on, GTransform on (Rep on)) => TransformBi on on where
transformBi f x = f (to (gtransform f (from x)))
{-# inline transformBi #-}

instance {-# overlapping #-} (Generic from, GTransform on (Rep from)) => TransformBi on from

transform :: TransformBi on on => (on -> on) -> on -> on
transform = transformBi

+ 87
- 0
src/Data/Generics/Plated/Universe.hs View File

@@ -0,0 +1,87 @@

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MonoLocalBinds #-}

module Data.Generics.Plated.Universe where

import GHC.Generics
import Data.DList

--------------
-- Universe --
--------------

class GUniverse struct to where
guniverse :: struct from -> DList to

instance GUniverse U1 to where
guniverse _ = mempty
{-# INLINE guniverse #-}

instance GUniverse V1 to where
guniverse _ = mempty
{-# INLINE guniverse #-}

instance {-# OVERLAPPING #-} UniverseRec to to => GUniverse (Rec0 to) to where
guniverse (K1 a) = a `cons` universeRec a
{-# INLINE guniverse #-}

instance UniverseRec from to => GUniverse (Rec0 from) to where
guniverse (K1 a) = universeRec a
{-# INLINE guniverse #-}

instance (GUniverse x to, GUniverse y to) => GUniverse (x :*: y) to where
guniverse (x :*: y) = guniverse x <> guniverse y
{-# INLINE guniverse #-}

instance (GUniverse x to, GUniverse y to) => GUniverse (x :+: y) to where
guniverse = \case
L1 x -> guniverse x
R1 y -> guniverse y
{-# INLINE guniverse #-}

instance GUniverse struct to => GUniverse (M1 _x _y struct) to where
guniverse (M1 a) = guniverse a

-- UniverseRec --

class UniverseRec from to where
universeRec :: from -> DList to
default universeRec :: (Generic from, GUniverse (Rep from) to) => from -> DList to
universeRec x = guniverse (from x)
{-# INLINE universeRec #-}

instance {-# overlapping #-} (Generic from, GUniverse (Rep from) to) => UniverseRec from to

instance {-# overlapping #-} UniverseRec Int to where
universeRec _ = mempty
{-# INLINE universeRec #-}

instance {-# overlapping #-} UniverseRec Integer to where
universeRec _ = mempty
{-# INLINE universeRec #-}

instance {-# overlapping #-} UniverseRec Char to where
universeRec _ = mempty
{-# INLINE universeRec #-}

-- UniverseBi --

class UniverseBi from to where
universeBi :: from -> [to]
default universeBi :: (Generic from, GUniverse (Rep from) to) => from -> [to]
universeBi x = toList (guniverse (from x))

instance {-# overlapping #-} (Generic from, GUniverse (Rep from) from) => UniverseBi from from where
universeBi x = x : toList (guniverse (from x))

instance {-# overlapping #-} (Generic from, GUniverse (Rep from) to) => UniverseBi from to

universe :: UniverseBi from from => from -> [from]
universe = universeBi

+ 6
- 0
stack.yaml View File

@@ -0,0 +1,6 @@
resolver: lts-14.21

packages:
- .

extra-deps: []

+ 166
- 0
test/Spec.hs View File

@@ -0,0 +1,166 @@
-- Taken from the uniplate library by Neil Mitchell

import Type
import Data.Char
import Data.Ratio
import qualified Data.Map as Map

import qualified Data.Generics.Uniplate.Data as U
import qualified Data.Generics.Plated as G

main :: IO ()
main = test



-- benchmark :: Benchmark
-- benchmark = Benchmark
-- variables_ zeros_ simplify_
-- rename_ symbols_ constFold_
-- (increase_ 100) (incrone_ "" 100) bill_

uvariables_, gvariables_ :: Expr -> [String]
uvariables_ x = [y | Var y <- U.universe x]
gvariables_ x = [y | Var y <- G.universe x]

uzeros_, gzeros_ :: Expr -> Int
uzeros_ x = length [() | Div _ (Val 0) <- U.universe x]
gzeros_ x = length [() | Div _ (Val 0) <- G.universe x]

usimplify_,gsimplify_ :: Expr -> Expr
usimplify_ = U.transform simp
gsimplify_ = G.transform simp

simp (Sub x y) = simp $ Add x (Neg y)
simp (Add x y) | x == y = Mul (Val 2) x
simp x = x

urename_,grename_ :: Stm -> Stm
urename_ = U.transformBi rename_op
where rename_op (V x) = V ("_" ++ x)
grename_ = G.transformBi rename_op
where rename_op (V x) = V ("_" ++ x)

usymbols_, gsymbols_ :: Stm -> [(Var,Typ)]
usymbols_ x = [(v,t) | SDecl t v <- U.universeBi x]
gsymbols_ x = [(v,t) | SDecl t v <- G.universeBi x]

uconstFold_, gconstFold_ :: Stm -> Stm
uconstFold_ = U.transformBi const_op
where
const_op (EAdd (EInt n) (EInt m)) = EInt (n+m)
const_op x = x
gconstFold_ = G.transformBi const_op
where
const_op (EAdd (EInt n) (EInt m)) = EInt (n+m)
const_op x = x


-- increase_ :: Integer -> Company -> Company
-- increase_ = increaseAny_

-- increaseAny_ :: Biplate a Salary => Integer -> a -> a
-- increaseAny_ k = transformBi (increase_op k)
-- where increase_op k (S s) = S (s+k)

{-
incrone_ :: String -> Integer -> Company -> Company
incrone_ name k = descendBi $ f name k
where
f name k a@(D n _ _) | name == n = increaseAny_ k a
| otherwise = descend (f name k) a
-}

ubill_, gbill_ :: Company -> Integer
ubill_ x = sum [x | S x <- U.universeBi x]
gbill_ x = sum [x | S x <- G.universeBi x]


test :: IO ()
test = do
putStrLn ""
putStrLn ""
let
check msg (a, b)
| a == b = return ()
| otherwise = putStrLn $ unlines
[ msg <> " failed:"
, "a: " <> show a
, "b: " <> show b
]

let expr1 = Add (Val 1) (Neg (Val 2))
check "universe expr1"
( U.universe expr1
, G.universe expr1
)
-- check "children expr1"
-- ( U.children expr1
-- , G.children expr1
-- )
check "transform expr1"
( U.transform (\x -> case x of Val n -> Val (n+1) ; _ -> x) expr1
, G.transform (\x -> case x of Val n -> Val (n+1) ; _ -> x) expr1
)

let stmt11 = SAss (V "v") (EInt 1)
stmt121 = SAss (V "x") (EInt 3)
stmt12 = SReturn (EAdd (EInt 1) (EStm stmt121))
stmt1 = SBlock [stmt11,stmt12]

check "universe stmt1"
( U.universe stmt1
, G.universe stmt1
--( Lens.universeOf Lens.gplate stmt1
--, Lens.universeOf Lens.uniplate stmt1
)
-- check "children stmt1"
-- ( U.children stmt1
-- , G.children stmt1
-- )
-- check "childrenBi stmt1"
-- ( U.childrenBi stmt1 :: [Exp]
-- , G.childrenBi stmt1 :: [Exp]
-- )

check "universeBi stmt1"
( [i | EInt i <- U.universeBi stmt1]
, [i | EInt i <- G.universeBi stmt1]
)

check "transformBi stmt1"
( U.transformBi (const ([] :: [Stm])) stmt1
, G.transformBi (const ([] :: [Stm])) stmt1
)
-- check "descend stmt1"
-- ( U.descend (const stmt121) stmt1
-- , G.descend (const stmt121) stmt1
-- )

{-
let str1 = "neil"
universe str1 === ["neil","eil","il","l",""]
children str1 === ["eil"]
universeBi str1 === "neil"
transformBi (reverse :: String -> String) str1 === "elin"
descendBi toUpper str1 === "NEIL"

let eith1 = Left str1 :: Either String Int
universeBi eith1 === ([] :: [Int])
childrenBi eith1 === str1

let mp1 = map toMap [Map.singleton "neil" (1::Int), Map.fromList [("morz",3),("test",4)], Map.empty]
universeBi mp1 === [1::Int,3,4]
universeBi (transformBi (+(1::Int)) mp1) === [2::Int,4,5]
let mp2 = map fromMap $ descendBi (reverse :: String -> String) mp1
map Map.keys mp2 === [["lien"],["tset","zrom"],[]]
map Map.valid mp2 === [True,True,True]

let rat1 = 1 % 2 :: Rational
universe rat1 === [rat1]
universeBi rat1 === [1::Integer,2::Integer]

let com1 = C [D "test" (E (P "fred" "bob") (S 12)) []]
universeBi com1 === [S 12]

-}

+ 12
- 0
test/Testset.hs
File diff suppressed because it is too large
View File


+ 104
- 0
test/Type.hs View File

@@ -0,0 +1,104 @@
-- Taken from the uniplate library by Neil Mitchell: https://github.com/ndmitchell/uniplate/blob/master/Uniplate/Type.hs

{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}

module Type where

import Control.DeepSeq
import Data.Data
import GHC.Generics

data Expr = Val Int
| Var String
| Neg Expr
| Add Expr Expr
| Sub Expr Expr
| Mul Expr Expr
| Div Expr Expr
deriving (Eq,Show,Data,Typeable,Generic)

data Stm = SDecl Typ Var
| SAss Var Exp
| SBlock [Stm]
| SReturn Exp
deriving (Eq,Show,Data,Typeable,Generic)

data Exp = EStm Stm
| EAdd Exp Exp
| EVar Var
| EInt Int
deriving (Eq,Show,Data,Typeable,Generic)

data Var = V String
deriving (Eq,Show,Data,Typeable,Generic)

data Typ = T_int | T_float
deriving (Eq,Show,Data,Typeable,Generic)

data Company = C [Dept] deriving (Eq,Show,Data,Typeable,Generic)
data Dept = D String Employee [Unt] deriving (Eq,Show,Data,Typeable,Generic)
data Unt = PU Employee | DU Dept deriving (Eq,Show,Data,Typeable,Generic)
data Employee = E Person Salary deriving (Eq,Show,Data,Typeable,Generic)
data Person = P String String deriving (Eq,Show,Data,Typeable,Generic)
data Salary = S Integer deriving (Eq,Show,Data,Typeable,Generic)


data Benchmark = Benchmark
{variables :: Expr -> [String]
,zeros :: Expr -> Int
,simplify :: Expr -> Expr
,rename :: Stm -> Stm
,symbols :: Stm -> [(Var,Typ)]
,constFold :: Stm -> Stm
,increase :: Company -> Company
,incrone :: Company -> Company
,bill :: Company -> Integer}


instance NFData Expr where
rnf (Val x1) = rnf x1 `seq` ()
rnf (Var x1) = rnf x1 `seq` ()
rnf (Neg x1) = rnf x1 `seq` ()
rnf (Add x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
rnf (Sub x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
rnf (Mul x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
rnf (Div x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

instance NFData Stm where
rnf (SDecl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
rnf (SAss x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
rnf (SBlock x1) = rnf x1 `seq` ()
rnf (SReturn x1) = rnf x1 `seq` ()

instance NFData Exp where
rnf (EStm x1) = rnf x1 `seq` ()
rnf (EAdd x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
rnf (EVar x1) = rnf x1 `seq` ()
rnf (EInt x1) = rnf x1 `seq` ()

instance NFData Var where
rnf (V x1) = rnf x1 `seq` ()

instance NFData Typ where
rnf T_int = ()
rnf T_float = ()

instance NFData Company where
rnf (C x1) = rnf x1 `seq` ()

instance NFData Dept where
rnf (D x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

instance NFData Unt where
rnf (PU x1) = rnf x1 `seq` ()
rnf (DU x1) = rnf x1 `seq` ()

instance NFData Employee where
rnf (E x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

instance NFData Person where
rnf (P x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

instance NFData Salary where
rnf (S x1) = rnf x1 `seq` ()


Loading…
Cancel
Save