HappyTree (empty) → 0.2018.1.5
raw patch · 8 files changed
+235/−0 lines, 8 filesdep +HappyTreedep +basedep +constraintssetup-changed
Dependencies added: HappyTree, base, constraints, generics-sop, singletons
Files
- ChangeLog.md +3/−0
- HappyTree.cabal +72/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- app/Main.hs +6/−0
- src/Lib.hs +119/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for HappyTree++## Unreleased changes
+ HappyTree.cabal view
@@ -0,0 +1,72 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: ca077430f4b90fc7a4a71fa0738c6711a609f4b20ff2f746b4e91c7aa4cc897c++name: HappyTree+version: 0.2018.1.5+description: Please see the README on Github at <https://github.com/MarisaKirisame/HappyTree#readme>+homepage: https://github.com/MarisaKirisame/HappyTree#readme+bug-reports: https://github.com/MarisaKirisame/HappyTree/issues+author: Marisa Kirisame+maintainer: lolisa@marisa.moe+copyright: 2018 Marisa Kirisame+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/MarisaKirisame/HappyTree++library+ hs-source-dirs:+ src+ ghc-options: -Wno-partial-type-signatures+ build-depends:+ base >=4.7 && <5+ , constraints ==0.9.1+ , generics-sop ==0.3.1.0+ , singletons ==2.3.1+ exposed-modules:+ Lib+ other-modules:+ Paths_HappyTree+ default-language: Haskell2010++executable HappyTree-exe+ main-is: Main.hs+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-partial-type-signatures+ build-depends:+ HappyTree+ , base >=4.7 && <5+ , constraints ==0.9.1+ , generics-sop ==0.3.1.0+ , singletons ==2.3.1+ other-modules:+ Paths_HappyTree+ default-language: Haskell2010++test-suite HappyTree-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HappyTree+ , base >=4.7 && <5+ , constraints ==0.9.1+ , generics-sop ==0.3.1.0+ , singletons ==2.3.1+ other-modules:+ Paths_HappyTree+ default-language: Haskell2010
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Marisa Kirisame (c) 2018++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 Marisa Kirisame 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.
+ README.md view
@@ -0,0 +1,1 @@+# HappyTree
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Lib++main :: IO ()+main = someFunc
+ src/Lib.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE + DataKinds,+ TypeFamilies,+ TemplateHaskell,+ PolyKinds,+ ExistentialQuantification,+ ScopedTypeVariables,+ UndecidableInstances,+ TypeOperators,+ UndecidableSuperClasses,+ GADTs,+ PartialTypeSignatures+#-}++module Lib where++import Data.Singletons.Prelude+import Data.Void+import Data.Singletons.TH+import qualified Generics.SOP as SOP+import Data.Constraint+import Data.Proxy++someFunc :: IO ()+someFunc = putStrLn "someFunc"++$(singletons [d|+ revAppend :: [a] -> [a] -> [a]+ revAppend [] x = x+ revAppend (x:xs) n = revAppend xs (x:n) + takeElemAux :: [a] -> [a] -> [(a, [a])]+ takeElemAux l [] = []+ takeElemAux l (r:rs) = (r, revAppend l rs) : takeElemAux (r:l) rs + takeElem :: [a] -> [(a, [a])]+ takeElem = takeElemAux []+ |])++class (SplitCode a ~ SOP.Code a, SOP.Generic a) => SplitStructure a where+ type SplitCode a :: [[*]]+ type SplitCode a = SOP.Code a+ splitStructureFrom :: a -> SOP.SOP SOP.I (SplitCode a)+ splitStructureFrom = SOP.from+ splitStructureTo :: SOP.SOP SOP.I (SplitCode a) -> a++class Ord a => SplitOrd a++newtype SplitStructureOnAux dt b r a = SplitStructureOnAux { runSplitStructureOnAux :: dt (r :++ a) b }++newtype SplitStructureOn dt b a =+ SplitStructureOn { runSplitStructureOn :: (Dict (SplitStructure (Fst a)), SOP.NP (SplitStructureOnAux dt b (Snd a)) (SplitCode (Fst a))) }++newtype SplitOrderOn dt b a = SplitOrderOn { runSplitOrderOn :: (Dict (SplitOrd (Fst a)), (Fst a), dt (Fst a:Snd a) b, dt (Snd a) b, dt (Fst a:Snd a) b) }++data DecisionTree (a :: [*]) (b :: *) =+ Leaf (SOP.NP SOP.I a -> b) |+ SplitOnStructure (SOP.NS (SplitStructureOn DecisionTree b) (TakeElem a)) |+ SplitOnOrd (SOP.NS (SplitOrderOn DecisionTree b) (TakeElem a))++newtype TakeElemTypeAux a = TakeElemTypeAux { runTakeElemTypeAux :: (Fst a, SOP.NP SOP.I (Snd a)) }++type family TakeElemAuxType (a :: [*]) (b :: [*]) :: *+type instance TakeElemAuxType a b = SOP.NP TakeElemTypeAux (TakeElemAux a b)++type family TakeElemType (a :: [*]) :: *+type instance TakeElemType a = TakeElemAuxType '[] a++revAppendDT :: SOP.NP f a -> SOP.NP f b -> SOP.NP f (RevAppend a b)+revAppendDT SOP.Nil x = x+revAppendDT (x SOP.:* y) z = revAppendDT y (x SOP.:* z)++takeElemAuxDT :: SOP.NP SOP.I a -> SOP.NP SOP.I b -> TakeElemAuxType a b+takeElemAuxDT _ SOP.Nil = SOP.Nil+takeElemAuxDT x (SOP.I y SOP.:* z) = TakeElemTypeAux (y, revAppendDT x z) SOP.:* takeElemAuxDT (SOP.I y SOP.:* x) z++dictSList :: SOP.SList a -> Dict (SOP.SListI a)+dictSList SOP.SNil = Dict+dictSList SOP.SCons = Dict++sListCons :: Proxy a -> SOP.SList b -> SOP.SList (a:b)+sListCons _ x = dictSList x `withDict` SOP.SCons++unSListCons :: forall (a :: [k]) . SOP.SList (_:a) -> SOP.SList a+unSListCons SOP.SCons = SOP.sList++takeElemAuxDTSingAux :: SOP.SList (a:as) -> Proxy a+takeElemAuxDTSingAux _ = Proxy++takeElemAuxDTSing :: SOP.SList a -> SOP.SList b -> SOP.SList (TakeElemAux a b)+takeElemAuxDTSing _ SOP.SNil = SOP.SNil+takeElemAuxDTSing x y@SOP.SCons =+ dictSList (takeElemAuxDTSing (sListCons (takeElemAuxDTSingAux y) x) (unSListCons y)) `withDict` SOP.SCons++takeElemDT :: SOP.NP SOP.I a -> TakeElemType a+takeElemDT = takeElemAuxDT SOP.Nil++sopAppend :: SOP.NP f a -> SOP.NP f b -> SOP.NP f (a :++ b)+sopAppend SOP.Nil x = x+sopAppend (x SOP.:* y) z = x SOP.:* sopAppend y z++npToSList :: SOP.NP f a -> SOP.SList a+npToSList SOP.Nil = SOP.SNil+npToSList (_ SOP.:* x) = sListCons Proxy (npToSList x)++eval :: DecisionTree a b -> SOP.NP SOP.I a -> b+eval (Leaf f) x = f x+eval (SplitOnStructure f) x =+ dictSList (takeElemAuxDTSing SOP.SNil (npToSList x)) `withDict`+ (SOP.hcollapse $ SOP.hzipWith+ (\(TakeElemTypeAux (a, b)) (SplitStructureOn (Dict, d)) ->+ let SOP.SOP e = splitStructureFrom a in+ SOP.K (SOP.hcollapse $ SOP.hzipWith (\(SplitStructureOnAux f) g -> SOP.K (eval f (sopAppend b g))) d e)) (takeElemDT x) f)+eval (SplitOnOrd f) x =+ dictSList (takeElemAuxDTSing SOP.SNil (npToSList x)) `withDict`+ (SOP.hcollapse $ SOP.hzipWith+ (\(TakeElemTypeAux (a, b)) (SplitOrderOn (Dict, d, e, f, g)) ->+ SOP.K (case a `compare` d of+ LT -> eval e (SOP.I a SOP.:* b)+ EQ -> eval f b+ GT -> eval g (SOP.I a SOP.:* b))) (takeElemDT x) f)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"